Add the --file-watch flag #113 (yay!)

Author: snoyberg

ChangeLog.md

@@ -8,6 +8,7 @@
 * Print latest version of packages on conflicts [#450](https://github.com/commercialhaskell/stack/issues/450)
 * Flag to avoid rerunning tests that haven't changed [#451](https://github.com/commercialhaskell/stack/issues/451)
 * stack can act as a script interpreter (see [Script interpreter] (https://github.com/commercialhaskell/stack/wiki/Script-interpreter) and [Reddit discussion](http://www.reddit.com/r/haskell/comments/3bd66h/stack_runghc_turtle_as_haskell_script_solution/))
+* Add the __`--file-watch`__ flag to auto-rebuild on file changes [#113](https://github.com/commercialhaskell/stack/issues/113)
 
 ## 0.1.1.0
 

src/Stack/Build.hs

@@ -26,7 +26,10 @@ import           Control.Monad.Trans.Resource
 import           Data.Function
 import           Data.Map.Strict (Map)
 import qualified Data.Map as Map
+import           Data.Set (Set)
+import qualified Data.Set as Set
 import           Network.HTTP.Client.Conduit (HasHttpManager)
+import           Path
 import           Path.IO
 import           Prelude hiding (FilePath, writeFile)
 import           Stack.Build.ConstructPlan
@@ -45,11 +48,22 @@ import           Stack.Types.Internal
 type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
 
 -- | Build
-build :: M env m => BuildOpts -> m ()
-build bopts = do
+build :: M env m
+      => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
+      -> BuildOpts
+      -> m ()
+build setLocalFiles bopts = do
     menv <- getMinimalEnvOverride
 
     (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts
+
+    -- Set local files, necessary for file watching
+    stackYaml <- asks $ bcStackYaml . getBuildConfig
+    liftIO $ setLocalFiles
+           $ Set.insert stackYaml
+           $ Set.unions
+           $ map lpFiles locals
+
     (installedMap, locallyRegistered) <-
         getInstalled menv
                      GetInstalledOpts

src/Stack/Build/Source.hs

@@ -201,11 +201,13 @@ loadLocals bopts latestVersion = do
         when (packageName pkg /= name) $ throwM
             $ MismatchedCabalName cabalfp (packageName pkg)
         mbuildCache <- tryGetBuildCache dir
+        files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp
         fileModTimes <- getPackageFileModTimes pkg cabalfp
         return LocalPackage
             { lpPackage = pkg
             , lpPackageFinal = pkgFinal
             , lpWanted = wanted
+            , lpFiles = files
             , lpDirtyFiles =
                   maybe True
                         ((/= fileModTimes) . buildCacheTimes)

src/Stack/Build/Types.hs

@@ -295,6 +295,8 @@ data BuildOpts =
             ,boptsCoverage :: !Bool
             -- ^ Enable code coverage report generation for test
             -- suites.
+            ,boptsFileWatch :: !Bool
+            -- ^ Watch files for changes and automatically rebuild
             }
   deriving (Show)
 
@@ -315,6 +317,7 @@ defaultBuildOpts = BuildOpts
     , boptsTestArgs = []
     , boptsOnlySnapshot = False
     , boptsCoverage = False
+    , boptsFileWatch = False
     }
 
 -- | Run a Setup.hs action after building a package, before installing.
@@ -353,6 +356,7 @@ data LocalPackage = LocalPackage
     , lpDir            :: !(Path Abs Dir)  -- ^ Directory of the package.
     , lpCabalFile      :: !(Path Abs File) -- ^ The .cabal file
     , lpDirtyFiles     :: !Bool            -- ^ are there files that have changed since the last build?
+    , lpFiles          :: !(Set (Path Abs File)) -- ^ all files used by this package
     , lpComponents     :: !(Set Text)      -- ^ components to build, passed directly to Setup.hs build
     }
     deriving Show

src/Stack/FileWatch.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+module Stack.FileWatch
+    ( fileWatch
+    , displayException
+    ) where
+
+import Blaze.ByteString.Builder (toLazyByteString, copyByteString)
+import Blaze.ByteString.Builder.Char.Utf8 (fromShow)
+import Control.Concurrent.Async (race_)
+import Control.Concurrent.STM
+import Control.Exception (Exception)
+import Control.Exception.Enclosed (tryAny)
+import Control.Monad (forever, unless)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map.Strict as Map
+import Data.Monoid ((<>))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.String (fromString)
+import Data.Traversable (forM)
+import Path
+import System.FSNotify
+import System.IO (stderr)
+
+-- | Display an exception to stderr
+displayException :: Exception e => e -> IO ()
+displayException e =
+    L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"
+
+-- | 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.
+fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ())
+          -> IO ()
+fileWatch inner = withManager $ \manager -> do
+    dirtyVar <- newTVarIO True
+    watchVar <- newTVarIO Map.empty
+
+    let onChange = atomically $ writeTVar dirtyVar True
+
+        setWatched :: Set (Path Abs File) -> IO ()
+        setWatched files = do
+            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 parent files
+
+            keepListening _dir listen () = Just $ return $ Just listen
+            stopListening = Map.map $ \f -> do
+                () <- f
+                return Nothing
+            startListening = Map.mapWithKey $ \dir () -> do
+                let dir' = fromString $ toFilePath dir
+                listen <- watchDir manager dir' (const True) (const onChange)
+                return $ Just listen
+
+    let watchInput = do
+            line <- getLine
+            unless (line == "quit") $ do
+                case line of
+                    "help" -> do
+                        putStrLn ""
+                        putStrLn "help: display this help"
+                        putStrLn "quit: exit"
+                        putStrLn "build: force a rebuild"
+                        putStrLn "watched: display watched directories"
+                    "build" -> onChange
+                    "watched" -> do
+                        watch <- readTVarIO watchVar
+                        mapM_ (putStrLn . toFilePath) (Map.keys watch)
+                    _ -> putStrLn $ "Unknown command: " ++ show line
+
+                watchInput
+
+    race_ watchInput $ forever $ do
+        atomically $ do
+            dirty <- readTVar dirtyVar
+            check dirty
+            writeTVar dirtyVar False
+
+        eres <- tryAny $ inner setWatched
+        case eres of
+            Left e -> displayException e
+            Right () -> putStrLn "Success! Waiting for next file change."
+
+        putStrLn "Type help for available commands"

src/Stack/Upgrade.hs

@@ -72,20 +72,7 @@ upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> d
                 (Just $ dir </> $(mkRelFile "stack.yaml"))
             lcLoadBuildConfig lc mresolver ThrowException
         envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv
-        runStackT manager logLevel envConfig1 terminal $ build BuildOpts
+        runStackT manager logLevel envConfig1 terminal $ build (const $ return ()) defaultBuildOpts
             { boptsTargets = ["stack"]
-            , boptsLibProfile = False
-            , boptsExeProfile = False
-            , boptsEnableOptimizations = Nothing
-            , boptsHaddock = False
-            , boptsHaddockDeps = Nothing
-            , boptsFinalAction = DoNothing
-            , boptsDryrun = False
-            , boptsGhcOptions = []
-            , boptsFlags = Map.empty
             , boptsInstallExes = True
-            , boptsPreFetch = False
-            , boptsTestArgs = []
-            , boptsOnlySnapshot = False
-            , boptsCoverage = False
             }

src/main/Main.hs

@@ -9,15 +9,12 @@
 
 module Main where
 
-import           Blaze.ByteString.Builder (toLazyByteString, copyByteString)
-import           Blaze.ByteString.Builder.Char.Utf8 (fromShow)
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader (ask)
 import           Data.Attoparsec.Args (withInterpreterArgs)
-import qualified Data.ByteString.Lazy as L
 import           Data.Char (toLower)
 import           Data.List
 import qualified Data.List as List
@@ -47,6 +44,7 @@ import qualified Stack.Docker as Docker
 import           Stack.Dot
 import           Stack.Exec
 import           Stack.Fetch
+import           Stack.FileWatch
 import           Stack.Init
 import           Stack.New
 import qualified Stack.PackageIndex
@@ -256,7 +254,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter ->
             case fromException e of
                 Just ec -> exitWith ec
                 Nothing -> do
-                    L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"
+                    displayException e
                     exitFailure
   where
     dockerHelpOptName = Docker.dockerCmdName ++ "-help"
@@ -512,13 +510,17 @@ readFlag = do
 
 -- | Build the project.
 buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()
-buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go ThrowException $
-    Stack.Build.build opts { boptsFinalAction = finalAction }
+buildCmd finalAction opts go
+    | boptsFileWatch opts = fileWatch inner
+    | otherwise = inner $ const $ return ()
+  where
+    inner setLocalFiles =
+        withBuildConfig go ThrowException $
+        Stack.Build.build setLocalFiles opts { boptsFinalAction = finalAction }
 
 -- | Install
 installCmd :: BuildOpts -> GlobalOpts -> IO ()
-installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $
-    Stack.Build.build opts { boptsInstallExes = True }
+installCmd opts = buildCmd DoNothing opts { boptsInstallExes = True }
 
 -- | Unpack packages to the filesystem
 unpackCmd :: [String] -> GlobalOpts -> IO ()
@@ -591,7 +593,7 @@ execCmd :: ExecOpts -> GlobalOpts -> IO ()
 execCmd ExecOpts {..} go = withBuildConfig go ExecStrategy $ do
     let targets = concatMap words eoPackages
     unless (null targets) $ do
-        Stack.Build.build defaultBuildOpts
+        Stack.Build.build (const $ return ()) defaultBuildOpts
             { boptsTargets = map T.pack targets
             }
     exec eoEnvSettings eoCmd eoArgs
@@ -649,7 +651,8 @@ buildOpts :: Command -> Parser BuildOpts
 buildOpts cmd = fmap process $
             BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>
             optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>
-            flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage
+            flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage <*>
+            fileWatch'
   where process bopts =
             if boptsCoverage bopts
                then bopts { boptsExeProfile = True
@@ -729,6 +732,10 @@ buildOpts cmd = fmap process $
                          help "Generate a code coverage report")
                else pure False
 
+        fileWatch' = flag False True
+            (long "file-watch" <>
+             help "Watch for changes in local files and automatically rebuild")
+
 -- | Parser for docker cleanup arguments.
 dockerCleanupOpts :: Parser Docker.CleanupOpts
 dockerCleanupOpts =

stack.cabal

@@ -50,6 +50,7 @@ library
                      Stack.Dot
                      Stack.Fetch
                      Stack.Exec
+                     Stack.FileWatch
                      Stack.GhcPkg
                      Stack.Init
                      Stack.New
@@ -103,9 +104,10 @@ library
                    , attoparsec >= 0.12.1.5
                    , base >= 4 && <5
                    , base16-bytestring
+                   , base64-bytestring
                    , bifunctors >= 4.2.1
                    , binary >= 0.7
-                   , base64-bytestring
+                   , blaze-builder
                    , bytestring
                    , conduit-combinators >= 0.3.1
                    , conduit >= 1.2.4
@@ -118,6 +120,7 @@ library
                    , exceptions >= 0.8.0.2
                    , fast-logger >= 2.3.1
                    , filepath >= 1.3.0.2
+                   , fsnotify
                    , hashable >= 1.2.3.2
                    , http-client >= 0.4.9
                    , http-client-tls >= 0.2.2
@@ -168,7 +171,6 @@ executable stack
                      Plugins.Commands
 
   build-depends:  base >=4.7 && < 5
-                , blaze-builder
                 , bytestring >= 0.10.4.0
                 , containers
                 , exceptions