Add --watch flag to build and test commands

README.md

@@ -399,6 +399,13 @@ E.g. if you wish to output your files in some other place than `output/`, you ca
 $ spago build -- -o myOutput/
 ```
 
+If you wish to automatically have your project rebuilt when making changes to source files
+you can use the `--watch` flag:
+
+```bash
+$ spago build --watch
+```
+
 Anyways, the above will create a whole lot of files, but you might want to get just a
 single, executable file. You'd then use the following:
 

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 module Main (main) where
 
 import qualified Data.Text as Text
@@ -8,7 +9,7 @@ import qualified System.Environment as Env
 import qualified Turtle as T
 
 import Spago.Build (ExtraArg (..), ModuleName (..), SourcePath (..),
- TargetPath (..), WithMain (..))
+ TargetPath (..), WithMain (..), Watch (..))
 import qualified Spago.Build
 import Spago.Packages (PackageName (..), PackagesFilter (..))
 import qualified Spago.Packages
@@ -34,7 +35,7 @@ data Command
 
  -- | Build the project paths src/ and test/
  -- plus the specified source paths
- | Build (Maybe Int) [SourcePath] [ExtraArg]
+ | Build (Maybe Int) Watch [SourcePath] [ExtraArg]
 
  -- | List available packages
  | ListPackages (Maybe PackagesFilter)
@@ -46,7 +47,7 @@ data Command
  | VerifySet (Maybe Int)
 
  -- | Test the project with some module, default Test.Main
- | Test (Maybe ModuleName) (Maybe Int) [SourcePath] [ExtraArg]
+ | Test (Maybe ModuleName) (Maybe Int) Watch [SourcePath] [ExtraArg]
 
  -- | Bundle the project, with optional main and target path arguments
  | Bundle (Maybe ModuleName) (Maybe TargetPath)
@@ -106,6 +107,12 @@ parser
  T.<|> version
  where
  force = T.switch "force" 'f' "Overwrite any project found in the current directory"
+ watchBool = T.switch "watch" 'w' "Watch for changes in local files and automatically rebuild"
+ watch = do
+ res <- watchBool
+ pure $ case res of
+ True -> Watch
+ False -> BuildOnce
  mainModule = T.optional (T.opt (Just . ModuleName) "main" 'm' "The main module to bundle")
  toTarget = T.optional (T.opt (Just . TargetPath) "to" 't' "The target file path")
  limitJobs = T.optional (T.optInt "jobs" 'j' "Limit the amount of jobs that can run concurrently")
@@ -158,15 +165,15 @@ parser
 
  build
  = T.subcommand "build" "Install the dependencies and compile the current package"
- $ Build <$> limitJobs <*> sourcePaths <*> passthroughArgs
+ $ Build <$> limitJobs <*> watch <*> sourcePaths <*> passthroughArgs
 
  repl
  = T.subcommand "repl" "Start a REPL"
  $ Repl <$> sourcePaths <*> passthroughArgs
 
  test
  = T.subcommand "test" "Test the project with some module, default Test.Main"
- $ Test <$> mainModule <*> limitJobs <*> sourcePaths <*> passthroughArgs
+ $ Test <$> mainModule <*> limitJobs <*> watch <*> sourcePaths <*> passthroughArgs
 
  bundle
  = T.subcommand "bundle" "Bundle the project, with optional main and target path arguments"
@@ -210,8 +217,9 @@ main = do
  VerifySet limitJobs -> Spago.Packages.verify limitJobs Nothing
  PackageSetUpgrade -> Spago.Packages.upgradePackageSet
  Freeze -> Spago.Packages.freeze
- Build limitJobs paths pursArgs -> Spago.Build.build limitJobs paths pursArgs
- Test modName limitJobs paths pursArgs -> Spago.Build.test modName limitJobs paths pursArgs
+ Build limitJobs watch paths pursArgs -> Spago.Build.build limitJobs watch paths pursArgs
+ Test modName limitJobs watch paths pursArgs
+ -> Spago.Build.test modName limitJobs watch paths pursArgs
  Repl paths pursArgs -> Spago.Build.repl paths pursArgs
  Bundle modName tPath -> Spago.Build.bundle WithMain modName tPath
  MakeModule modName tPath -> Spago.Build.makeModule modName tPath

app/Spago/Build.hs

@@ -4,23 +4,31 @@ module Spago.Build
  , repl
  , bundle
  , makeModule
+ , Watch (..)
  , Purs.ExtraArg (..)
  , Purs.ModuleName (..)
  , Purs.SourcePath (..)
  , Purs.TargetPath (..)
  , Purs.WithMain (..)
  ) where
 
-import Control.Exception (SomeException, try)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as Text
-import System.IO (hPutStrLn)
-import qualified Turtle as T hiding (die, echo)
+import Control.Exception (SomeException, try)
+import Data.Maybe (fromMaybe)
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import System.Directory (makeAbsolute)
+import qualified System.FilePath.Glob as Glob
+import System.IO (hPutStrLn)
+import qualified Turtle as T hiding (die, echo)
 
-import qualified Spago.Config as Config
-import qualified Spago.Packages as Packages
-import qualified Spago.Purs as Purs
+import qualified Spago.Config  as Config
+import qualified Spago.Packages  as Packages
+import qualified Spago.Purs  as Purs
 import Spago.Turtle
+import Spago.Watch (watch)
+
+
+data Watch = Watch | BuildOnce
 
 
 defaultSourcePaths :: [Purs.SourcePath]
@@ -41,13 +49,18 @@ prepareBundleDefaults maybeModuleName maybeTargetPath = (moduleName, targetPath)
 
 -- | Build the project with purs, passing through
 -- the additional args in the list
-build :: (Maybe Int) -> [Purs.SourcePath] -> [Purs.ExtraArg] -> IO ()
-build maybeLimit sourcePaths passthroughArgs = do
+build :: Maybe Int -> Watch -> [Purs.SourcePath] -> [Purs.ExtraArg] -> IO ()
+build maybeLimit shouldWatch sourcePaths passthroughArgs = do
  config <- Config.ensureConfig
  deps <- Packages.getProjectDeps config
  Packages.fetchPackages maybeLimit deps
- let globs = Packages.getGlobs deps <> defaultSourcePaths <> sourcePaths
- Purs.compile globs passthroughArgs
+ let projectGlobs = defaultSourcePaths <> sourcePaths
+ allGlobs = Packages.getGlobs deps <> projectGlobs
+ buildAction = Purs.compile allGlobs passthroughArgs
+ absoluteProjectGlobs <- traverse makeAbsolute $ Text.unpack . Purs.unSourcePath <$> projectGlobs
+ case shouldWatch of
+ BuildOnce -> buildAction
+ Watch -> watch (Set.fromAscList $ fmap Glob.compile absoluteProjectGlobs) buildAction
 
 -- | Start a repl
 repl :: [Purs.SourcePath] -> [Purs.ExtraArg] -> IO ()
@@ -59,17 +72,17 @@ repl sourcePaths passthroughArgs = do
 
 -- | Test the project: compile and run the Test.Main
 -- (or the provided module name) with node
-test :: Maybe Purs.ModuleName -> Maybe Int -> [Purs.SourcePath] -> [Purs.ExtraArg] -> IO ()
-test maybeModuleName maybeLimit paths passthroughArgs = do
- build maybeLimit paths passthroughArgs
+test :: Maybe Purs.ModuleName -> Maybe Int -> Watch -> [Purs.SourcePath] -> [Purs.ExtraArg] -> IO ()
+test maybeModuleName maybeLimit shouldWatch paths passthroughArgs = do
+ build maybeLimit shouldWatch paths passthroughArgs
  T.shell cmd T.empty >>= \case
  T.ExitSuccess -> echo "Tests succeeded."
  T.ExitFailure n -> die $ "Tests failed: " <> T.repr n
  where
  moduleName = fromMaybe (Purs.ModuleName "Test.Main") maybeModuleName
  cmd = "node -e \"require('./output/" <> Purs.unModuleName moduleName <> "').main()\""
 
--- | Bundle the project to a js file
+ -- | Bundle the project to a js file
 bundle :: Purs.WithMain -> Maybe Purs.ModuleName -> Maybe Purs.TargetPath -> IO ()
 bundle withMain maybeModuleName maybeTargetPath =
  let (moduleName, targetPath) = prepareBundleDefaults maybeModuleName maybeTargetPath

app/Spago/Watch.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE TupleSections #-}
+module Spago.Watch (watch, globToParent) where
+
+-- This code basically comes straight from
+-- https://github.com/commercialhaskell/stack/blob/0740444175f41e6ea5ed236cd2c53681e4730003/src/Stack/FileWatch.hs
+
+
+import Control.Concurrent.Async (race_)
+import Control.Concurrent.STM (check)
+import Control.Exception (SomeException, catch, throwIO, try)
+import Control.Monad (forM, forever, unless, when)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import GHC.Conc (atomically, newTVarIO, readTVar, readTVarIO, writeTVar)
+import GHC.IO.Exception
+import System.FilePath (isAbsolute, pathSeparator, (</>))
+import qualified System.FilePath.Glob as Glob
+import qualified System.FSNotify as Watch
+import System.IO (getLine)
+
+import Spago.Turtle
+
+
+watch :: Set.Set Glob.Pattern -> IO () -> IO ()
+watch globs action = do
+ let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 0.1 } -- in seconds
+ fileWatchConf config $ \getGlobs -> do
+ getGlobs globs
+ action
+
+
+-- | Run an action, watching for file changes
+--
+-- The action provided takes a callback that is used to set the files to be
+-- watched. When any of those files are changed, we rerun the action again.
+fileWatchConf :: Watch.WatchConfig
+ -> ((Set.Set Glob.Pattern -> IO ()) -> IO ())
+ -> IO ()
+fileWatchConf watchConfig inner = Watch.withManagerConf watchConfig $ \manager -> do
+ allGlobs <- newTVarIO Set.empty
+ dirtyVar <- newTVarIO True
+ watchVar <- newTVarIO Map.empty
+
+ let onChange event = do
+ globsUnsafe <- readTVarIO allGlobs
+ let shouldRebuild globs = or $ fmap (\glob -> Glob.match glob $ Watch.eventPath event) $ Set.toList globs
+ when (shouldRebuild globsUnsafe) $
+ echoStr $ "File changed, rebuilding: " <> show (Watch.eventPath event)
+ atomically $ do
+ globs <- readTVar allGlobs
+ when (shouldRebuild globs)
+ (writeTVar dirtyVar True)
+
+ setWatched :: Set.Set Glob.Pattern -> IO ()
+ setWatched globs = do
+ atomically $ writeTVar allGlobs globs
+ watch0 <- readTVarIO watchVar
+ let actions = Map.mergeWithKey
+ keepListening
+ stopListening
+ startListening
+ watch0
+ newDirs
+ watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
+ mv <- mmv
+ return $
+ case mv of
+ Nothing -> Map.empty
+ Just v -> Map.singleton k v
+ atomically $ writeTVar watchVar $ Map.unions watch1
+ where
+ newDirs = Map.fromList $ map (, ())
+ $ Set.toList
+ $ Set.map globToParent globs
+
+ keepListening _dir listen () = Just $ return $ Just listen
+
+ stopListening = Map.map $ \f -> do
+ () <- f `catch` \ioe ->
+ -- Ignore invalid argument error - it can happen if
+ -- the directory is removed.
+ case ioe_type ioe of
+ InvalidArgument -> return ()
+ _ -> throwIO ioe
+ return Nothing
+
+ startListening = Map.mapWithKey $ \dir () -> do
+ -- let dir' = fromString $ toFilePath dir
+ listen <- Watch.watchTree manager dir (const True) onChange
+ return $ Just listen
+
+ let watchInput = do
+ line <- getLine
+ unless (line == "quit") $ do
+ case line of
+ "help" -> do
+ echo ""
+ echo "help: display this help"
+ echo "quit: exit"
+ echo "build: force a rebuild"
+ echo "watched: display watched files"
+ "build" -> atomically $ writeTVar dirtyVar True
+ "watched" -> do
+ watch' <- readTVarIO allGlobs
+ mapM_ echoStr (Glob.decompile <$> Set.toList watch')
+ "" -> atomically $ writeTVar dirtyVar True
+ _ -> echoStr $ concat
+ [ "Unknown command: "
+ , show line
+ , ". Try 'help'"
+ ]
+
+ watchInput
+
+ race_ watchInput $ forever $ do
+ atomically $ do
+ dirty <- readTVar dirtyVar
+ check dirty
+ writeTVar dirtyVar False
+
+ eres :: Either SomeException () <- try $ inner setWatched
+
+ case eres of
+ Left e -> echoStr $ show e
+ _ -> echo "Success! Waiting for next file change."
+
+ echo "Type help for available commands. Press enter to force a rebuild."
+
+
+globToParent :: Glob.Pattern -> FilePath
+globToParent glob = go base $ map Text.unpack pathComponents
+ where
+ path = Glob.decompile glob
+
+ base = case isAbsolute path of
+ True -> [pathSeparator]
+ False -> "."
+
+ pathComponents = Text.split (== pathSeparator) $ Text.pack path
+
+ go acc [] = acc
+ go acc ("*":_rest) = acc
+ go acc ("**":_rest) = acc
+ go acc [_file] = acc
+ go acc (h:rest) = go (acc </> h) rest

package.yaml

@@ -39,6 +39,7 @@ dependencies:
 - turtle
 - filepath
 - file-embed
+- template-haskell
 - aeson
 - aeson-pretty
 - containers
@@ -48,12 +49,16 @@ dependencies:
 - prettyprinter
 - async-pool
 - process
-- template-haskell
 - network-uri
 - github
 - versions
 - microlens
 - safe
+- fsnotify
+- Glob
+- async
+- stm
+- directory
 
 executables:
  spago:

stack.yaml

@@ -12,3 +12,4 @@ extra-deps:
 - repline-0.2.0.0
 - serialise-0.2.1.0
 - Win32-2.5.4.1@sha256:e623a1058bd8134ec14d62759f76cac52eee3576711cb2c4981f398f1ec44b85
+- Glob-0.10.0