--file-watch should respect VCS boring/ignore files

agrafix · agrafix · commit f66484397fc3 · 2015-08-22T21:43:22.000+02:00
diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs
@@ -19,6 +19,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.String (fromString)
 import Data.Traversable (forM)
+import Ignore
 import Path
 import System.FSNotify
 import System.IO (stderr)
@@ -32,11 +33,20 @@ printExceptionStderr e =
 --
 -- 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 ())
+fileWatch :: IO (Path Abs Dir)
+          -> ((Set (Path Abs File) -> IO ()) -> IO ())
           -> IO ()
-fileWatch inner = withManager $ \manager -> do
+fileWatch getProjectRoot inner = withManager $ \manager -> do
     dirtyVar <- newTVarIO True
     watchVar <- newTVarIO Map.empty
+    projRoot <- getProjectRoot
+    mChecker <- findIgnoreFiles [VCSGit, VCSMercurial, VCSDarcs] projRoot >>= buildChecker
+    (FileIgnoredChecker isFileIgnored) <-
+        case mChecker of
+          Left err ->
+              do putStrLn $ "Failed to parse VCS's ignore file: " ++ err
+                 return $ FileIgnoredChecker (const False)
+          Right chk -> return chk
 
     let onChange = atomically $ writeTVar dirtyVar True
 
@@ -67,7 +77,7 @@ fileWatch inner = withManager $ \manager -> do
                 return Nothing
             startListening = Map.mapWithKey $ \dir () -> do
                 let dir' = fromString $ toFilePath dir
-                listen <- watchDir manager dir' (const True) (const onChange)
+                listen <- watchDir manager dir' (not . isFileIgnored . eventPath) (const onChange)
                 return $ Just listen
 
     let watchInput = do
diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs
@@ -154,7 +154,7 @@ buildOptsParser cmd =
 
         fileWatch' = flag False True
             (long "file-watch" <>
-             help "Watch for changes in local files and automatically rebuild")
+             help "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file")
 
         keepGoing = maybeBoolFlags
             "keep-going"
diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -666,7 +666,14 @@ cleanCmd () go = withBuildConfigAndLock go (\_ -> clean)
 buildCmd :: Maybe (Text, Text) -- ^ option synonym
          -> BuildOpts -> GlobalOpts -> IO ()
 buildCmd moptionSynonym opts go
-    | boptsFileWatch opts = fileWatch inner
+    | boptsFileWatch opts =
+        let getProjectRoot =
+                do (manager, lc) <- loadConfigWithOpts go
+                   bconfig <-
+                       runStackLoggingTGlobal manager go $
+                       lcLoadBuildConfig lc (globalResolver go)
+                   return (bcRoot bconfig)
+        in fileWatch getProjectRoot inner
     | otherwise = inner $ const $ return ()
   where
     inner setLocalFiles = withBuildConfigAndLock go $ \lk -> do
diff --git a/stack.cabal b/stack.cabal
@@ -133,6 +133,7 @@ library
                    , http-client-tls >= 0.2.2
                    , http-conduit >= 2.1.7
                    , http-types >= 0.8.6
+                   , ignore >= 0.1
                    , lifted-base
                    , monad-control
                    , monad-logger >= 0.3.13.1
diff --git a/stack.yaml b/stack.yaml
@@ -1,5 +1,6 @@
 resolver: lts-3.0
-
+extra-deps:
+- ignore-0.1.0.0
 image:
   container:
     base: "fpco/ubuntu-with-libgmp:14.04"
