diff --git a/shake.cabal b/shake.cabal index 0497ea8c..b02a8f64 100644 --- a/shake.cabal +++ b/shake.cabal @@ -93,11 +93,13 @@ library base >= 4.9, binary, bytestring, + containers, deepseq >= 1.1, directory >= 1.2.7.0, extra >= 1.6.19, filepath >= 1.4, filepattern, + fsnotify, hashable >= 1.1.2.3, heaps >= 0.3.6.1, js-dgtable, @@ -218,11 +220,13 @@ executable shake base == 4.*, binary, bytestring, + containers, deepseq >= 1.1, directory, extra >= 1.6.19, filepath, filepattern, + fsnotify, hashable >= 1.1.2.3, heaps >= 0.3.6.1, js-dgtable, diff --git a/src/Development/Shake/Internal/Args.hs b/src/Development/Shake/Internal/Args.hs index df6f2696..d0e0280e 100644 --- a/src/Development/Shake/Internal/Args.hs +++ b/src/Development/Shake/Internal/Args.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Command line parsing flags. module Development.Shake.Internal.Args( @@ -35,7 +36,10 @@ import System.Directory.Extra import System.Environment import System.Exit import System.Time.Extra - +import System.FSNotify +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map +import Control.Concurrent.MVar -- | Main entry point for running Shake build systems. For an example see the top of the module "Development.Shake". -- Use 'ShakeOptions' to specify how the system runs, and 'Rules' to specify what to build. The function will throw @@ -50,7 +54,6 @@ shake opts rules = do shakeRunDatabase db [] shakeRunAfter opts after - -- | Run a build system using command line arguments for configuration. -- The available flags are those from 'shakeOptDescrs', along with a few additional -- @make@ compatible flags that are not represented in 'ShakeOptions', such as @--print-directory@. @@ -136,7 +139,7 @@ shakeArgsOptionsWith -> [OptDescr (Either String a)] -> (ShakeOptions -> [a] -> [String] -> IO (Maybe (ShakeOptions, Rules ()))) -> IO () -shakeArgsOptionsWith baseOpts userOptions rules = do +shakeArgsOptionsWith baseOpts userOptions getOptsAndRules = do addTiming "shakeArgsWith" let baseOpts2 = removeOverlap userOptions $ map snd shakeOptsEx args <- getArgs @@ -163,7 +166,7 @@ shakeArgsOptionsWith baseOpts userOptions rules = do (targets, helpSuffix) <- if not long then pure ([], []) else handleSynchronous (\e -> do putWhenLn Info $ "Failure to collect targets: " ++ show e; pure ([], [])) $ do -- run the rules as simply as we can - rs <- rules shakeOpts [] [] + rs <- getOptsAndRules shakeOpts [] [] case rs of Just (_, rs) -> do xs <- getTargets shakeOpts rs @@ -219,7 +222,7 @@ shakeArgsOptionsWith baseOpts userOptions rules = do appendFile file $ show (t,p) ++ "\n" pure p } - (ran,shakeOpts,res) <- redir $ do + redir $ do when printDirectory $ do curdir <- getCurrentDirectory putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" @@ -229,43 +232,79 @@ shakeArgsOptionsWith baseOpts userOptions rules = do if use then second withThreadSlave <$> compactUI shakeOpts else pure (shakeOpts, id) - rules <- rules shakeOpts user files - ui $ case rules of - Nothing -> pure (False, shakeOpts, Right ()) + optsAndRules <- getOptsAndRules shakeOpts user files + ui $ case optsAndRules of + Nothing -> return () Just (shakeOpts, rules) -> do - res <- try_ $ shake shakeOpts $ - if NoBuild `elem` flagsExtra then - withoutActions rules - else if ShareList `elem` flagsExtra || - not (null shareRemoves) || - ShareSanity `elem` flagsExtra then do - action $ do - unless (null shareRemoves) $ - actionShareRemove shareRemoves - when (ShareList `elem` flagsExtra) - actionShareList - when (ShareSanity `elem` flagsExtra) - actionShareSanity - withoutActions rules + let rules2 = if NoBuild `elem` flagsExtra then + withoutActions rules + else if ShareList `elem` flagsExtra || + not (null shareRemoves) || + ShareSanity `elem` flagsExtra then do + action $ do + unless (null shareRemoves) $ + actionShareRemove shareRemoves + when (ShareList `elem` flagsExtra) + actionShareList + when (ShareSanity `elem` flagsExtra) + actionShareSanity + withoutActions rules + else + rules + + let maybeWatch | shakeWatch shakeOpts = watch + | otherwise = shakeWithDatabase + + maybeWatch shakeOpts rules2 $ \db -> do + res <- try_ $ do + (_, after) <- shakeRunDatabase db [] + shakeRunAfter shakeOpts after + + if shakeVerbosity shakeOpts < Info || NoTime `elem` flagsExtra then + either throwIO pure res else - rules - pure (True, shakeOpts, res) - - if not ran || shakeVerbosity shakeOpts < Info || NoTime `elem` flagsExtra then - either throwIO pure res - else - let esc = if shakeColor shakeOpts then escape else \_ x -> x - in case res of - Left err -> - if Exception `elem` flagsExtra then - throwIO err - else do - putWhenLn Error $ esc Red $ show err - exitFailure - Right () -> do - tot <- start - putWhenLn Info $ esc Green $ "Build completed in " ++ showDuration tot - + let esc = if shakeColor shakeOpts then escape else \_ x -> x + in case res of + Left err -> + if Exception `elem` flagsExtra then + throwIO err + else do + putWhenLn Error $ esc Red $ show err + exitFailure + Right () -> do + tot <- start + putWhenLn Info $ esc Green $ "Build completed in " ++ showDuration tot + +watch :: ShakeOptions -> Rules () -> (ShakeDatabase -> IO ()) -> IO () +watch shakeOpts rules build = shakeWithDatabase shakeOpts rules $ \db -> withManager $ \mgr -> do + let loop = do + sleep 0.1 -- Wait for file writes to finish + + liveFiles <- mapM makeAbsolute =<< shakeLiveFilesDatabase db + if null liveFiles then do + putStrLn "No files to watch for changes, stopping" + else do + changeVar <- newEmptyMVar + let onChange = putMVar changeVar () + let awaitChange = takeMVar changeVar + let dirToFiles = Map.fromListWith Set.union $ + map (\abs -> (takeDirectory abs, Set.singleton abs)) liveFiles + let startWatchers = forM (Map.toList dirToFiles) $ \(dir, liveFilesInDir) -> do + let isChangeToLiveFile (Modified path _ _) = path `Set.member` liveFilesInDir + isChangeToLiveFile _ = False + watchDir mgr dir isChangeToLiveFile $ \_ -> onChange + let stopWatchers stopFns = sequence stopFns + let watchForChange = bracket startWatchers stopWatchers $ \_ -> do + putStrLn "Watching for file changes... 👀" + awaitChange + + watchForChange + build db + loop + + catch + (build db >> loop) -- Do an initial build, then enter a loop that watches for changes before rebuilding + (\(_ :: ExitCode) -> loop) -- Keep going if the build fails, but exit if the user presses Ctrl-C -- | A list of command line options that can be used to modify 'ShakeOptions'. Each option returns -- either an error message (invalid argument to the flag) or a function that changes some fields @@ -290,6 +329,7 @@ data Extra = ChangeDirectory FilePath | ShareSanity | ShareRemove String | Compact Auto + | Watch deriving Eq data Auto = Yes | No | Auto @@ -367,6 +407,7 @@ shakeOptsEx = ,extr $ Option "v" ["version"] (noArg [Version]) "Print the version number and exit." ,extr $ Option "w" ["print-directory"] (noArg [PrintDirectory True]) "Print the current directory." ,extr $ Option "" ["no-print-directory"] (noArg [PrintDirectory False]) "Turn off -w, even if it was turned on implicitly." + ,opts $ Option "" ["watch"] (noArg $ \s -> s{shakeWatch=True}) "Watch for changes and rebuild." ] where opts o = (True, fmapFmapOptDescr ([],) o) diff --git a/src/Development/Shake/Internal/Options.hs b/src/Development/Shake/Internal/Options.hs index 1a15bcda..1b7f488d 100644 --- a/src/Development/Shake/Internal/Options.hs +++ b/src/Development/Shake/Internal/Options.hs @@ -216,6 +216,8 @@ data ShakeOptions = ShakeOptions -- undefined results. Provided for compatibility with @ninja@. ,shakeAllowRedefineRules :: Bool -- ^ Whether to allow calling addBuiltinRule for the same key more than once + ,shakeWatch :: Bool + -- ^ Defaults to @False@. Whether to watch for file changes and rebuild. ,shakeProgress :: IO Progress -> IO () -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported. -- The function is called on a separate thread, and that thread is killed when the build completes. @@ -240,7 +242,7 @@ data ShakeOptions = ShakeOptions shakeOptions :: ShakeOptions shakeOptions = ShakeOptions ".shake" 1 "1" Info False [] Nothing [] [] [] [] (Just 10) [] [] False True False - True ChangeModtime True [] False False Nothing [] False False False + True ChangeModtime True [] False False Nothing [] False False False False (const $ pure ()) (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS (\_ _ _ -> pure ()) @@ -252,20 +254,20 @@ fieldsShakeOptions = ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog" ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck" ,"shakeLiveFiles", "shakeVersionIgnore", "shakeColor", "shakeShare", "shakeCloud", "shakeSymlink" - ,"shakeNeedDirectory", "shakeCanRedefineRules" + ,"shakeNeedDirectory", "shakeCanRedefineRules", "shakeWatch" ,"shakeProgress", "shakeOutput", "shakeTrace", "shakeExtra"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix -unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 y1 y2 y3 y4 = - ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 +unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 y1 y2 y3 y4 = + ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 (fromHidden y1) (fromHidden y2) (fromHidden y3) (fromHidden y4) instance Data ShakeOptions where - gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 y1 y2 y3 y4) = + gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 y1 y2 y3 y4) = z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` - x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k` x26 `k` x27 `k` x28 `k` + x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k` x26 `k` x27 `k` x28 `k` x29 `k` Hidden y1 `k` Hidden y2 `k` Hidden y3 `k` Hidden y4 - gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide + gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions