From 459a05af9583a1933aa3f5beafb6dc9a0cba27ad Mon Sep 17 00:00:00 2001 From: Chris Wendt Date: Thu, 23 Mar 2023 15:52:12 -0600 Subject: [PATCH 1/2] wip --- shake.cabal | 4 + src/Development/Shake/Internal/Args.hs | 147 +++++++++++++++------- src/Development/Shake/Internal/Options.hs | 16 +-- 3 files changed, 112 insertions(+), 55 deletions(-) diff --git a/shake.cabal b/shake.cabal index 0497ea8c1..b02a8f642 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 df6f26964..08b69411f 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,6 +54,14 @@ shake opts rules = do shakeRunDatabase db [] shakeRunAfter opts after +-- | Like 'shake', but takes a 'ShakeDatabase' as an argument. This enables the +-- caller to read the live files from the DB after the build and watch those +-- files for changes. +shakeUsingDb :: ShakeDatabase -> ShakeOptions -> Rules () -> IO () +shakeUsingDb db opts rules = do + addTiming "Function shake" + (_, after) <- 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 @@ -156,6 +168,13 @@ shakeArgsOptionsWith baseOpts userOptions rules = do then outputColor (shakeOutput oshakeOpts) else shakeOutput oshakeOpts } + rules2 <- rules shakeOpts user files + let maybeWatch = case rules2 of + Nothing -> shakeWithDatabase shakeOpts (return ()) + Just (shakeOpts', rules') -> if shakeWatch shakeOpts + then watch shakeOpts rules' + else shakeWithDatabase shakeOpts rules' + let putWhen v msg = when (shakeVerbosity oshakeOpts >= v) $ shakeOutput oshakeOpts v msg let putWhenLn v msg = putWhen v $ msg ++ "\n" let showHelp long = do @@ -219,53 +238,83 @@ shakeArgsOptionsWith baseOpts userOptions rules = do appendFile file $ show (t,p) ++ "\n" pure p } - (ran,shakeOpts,res) <- redir $ do - when printDirectory $ do - curdir <- getCurrentDirectory - putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" - (shakeOpts, ui) <- do - let compact = lastDef No [x | Compact x <- flagsExtra] - use <- if compact == Auto then checkEscCodes else pure $ compact == Yes - 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 ()) - 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 - 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 - + maybeWatch $ \db -> do + (ran,shakeOpts,res) <- redir $ do + when printDirectory $ do + curdir <- getCurrentDirectory + putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" + (shakeOpts, ui) <- do + let compact = lastDef No [x | Compact x <- flagsExtra] + use <- if compact == Auto then checkEscCodes else pure $ compact == Yes + if use + then second withThreadSlave <$> compactUI shakeOpts + else pure (shakeOpts, id) + ui $ case rules2 of + Nothing -> pure (False, shakeOpts, Right ()) + Just (shakeOpts, rules) -> do + res <- try_ $ shakeUsingDb db 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 + 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 + +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 +339,7 @@ data Extra = ChangeDirectory FilePath | ShareSanity | ShareRemove String | Compact Auto + | Watch deriving Eq data Auto = Yes | No | Auto @@ -367,6 +417,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 1a15bcda6..1b7f488db 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 From 14e6da29362d604ac1606c9b68732461a8fbf27f Mon Sep 17 00:00:00 2001 From: Chris Wendt Date: Thu, 23 Mar 2023 16:17:15 -0600 Subject: [PATCH 2/2] simplify --- src/Development/Shake/Internal/Args.hs | 90 ++++++++++++-------------- 1 file changed, 40 insertions(+), 50 deletions(-) diff --git a/src/Development/Shake/Internal/Args.hs b/src/Development/Shake/Internal/Args.hs index 08b69411f..d0e0280e3 100644 --- a/src/Development/Shake/Internal/Args.hs +++ b/src/Development/Shake/Internal/Args.hs @@ -54,15 +54,6 @@ shake opts rules = do shakeRunDatabase db [] shakeRunAfter opts after --- | Like 'shake', but takes a 'ShakeDatabase' as an argument. This enables the --- caller to read the live files from the DB after the build and watch those --- files for changes. -shakeUsingDb :: ShakeDatabase -> ShakeOptions -> Rules () -> IO () -shakeUsingDb db opts rules = do - addTiming "Function shake" - (_, after) <- 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@. @@ -148,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 @@ -168,13 +159,6 @@ shakeArgsOptionsWith baseOpts userOptions rules = do then outputColor (shakeOutput oshakeOpts) else shakeOutput oshakeOpts } - rules2 <- rules shakeOpts user files - let maybeWatch = case rules2 of - Nothing -> shakeWithDatabase shakeOpts (return ()) - Just (shakeOpts', rules') -> if shakeWatch shakeOpts - then watch shakeOpts rules' - else shakeWithDatabase shakeOpts rules' - let putWhen v msg = when (shakeVerbosity oshakeOpts >= v) $ shakeOutput oshakeOpts v msg let putWhenLn v msg = putWhen v $ msg ++ "\n" let showHelp long = do @@ -182,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 @@ -238,22 +222,21 @@ shakeArgsOptionsWith baseOpts userOptions rules = do appendFile file $ show (t,p) ++ "\n" pure p } - maybeWatch $ \db -> do - (ran,shakeOpts,res) <- redir $ do - when printDirectory $ do - curdir <- getCurrentDirectory - putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" - (shakeOpts, ui) <- do - let compact = lastDef No [x | Compact x <- flagsExtra] - use <- if compact == Auto then checkEscCodes else pure $ compact == Yes - if use - then second withThreadSlave <$> compactUI shakeOpts - else pure (shakeOpts, id) - ui $ case rules2 of - Nothing -> pure (False, shakeOpts, Right ()) - Just (shakeOpts, rules) -> do - res <- try_ $ shakeUsingDb db shakeOpts $ - if NoBuild `elem` flagsExtra then + redir $ do + when printDirectory $ do + curdir <- getCurrentDirectory + putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" + (shakeOpts, ui) <- do + let compact = lastDef No [x | Compact x <- flagsExtra] + use <- if compact == Auto then checkEscCodes else pure $ compact == Yes + if use + then second withThreadSlave <$> compactUI shakeOpts + else pure (shakeOpts, id) + optsAndRules <- getOptsAndRules shakeOpts user files + ui $ case optsAndRules of + Nothing -> return () + Just (shakeOpts, rules) -> do + let rules2 = if NoBuild `elem` flagsExtra then withoutActions rules else if ShareList `elem` flagsExtra || not (null shareRemoves) || @@ -268,22 +251,29 @@ shakeArgsOptionsWith baseOpts userOptions rules = do withoutActions rules 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 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 + 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