Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add --watch option to rebuild when any live file changes #839

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Add --watch option to rebuild when any live file changes #839

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
459a05a
wip
chrismwendt Mar 23, 2023
14e6da2
simplify
chrismwendt Mar 23, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
4 changes: 4 additions & 0 deletions shake.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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,
Expand Down
121 changes: 81 additions & 40 deletions src/Development/Shake/Internal/Args.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Command line parsing flags.
module Development.Shake.Internal.Args(
Expand Down Expand Up @@ -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
Expand All @@ -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@.
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 ++ "'"
Expand All @@ -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
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Turn off whitespace changes when reviewing this section - it's not as complex as it looks:

CleanShot 2023-03-23 at 16 36 38@2x


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
Expand All @@ -290,6 +329,7 @@ data Extra = ChangeDirectory FilePath
| ShareSanity
| ShareRemove String
| Compact Auto
| Watch
deriving Eq

data Auto = Yes | No | Auto
Expand Down Expand Up @@ -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)
Expand Down
16 changes: 9 additions & 7 deletions src/Development/Shake/Internal/Options.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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 ())
Expand All @@ -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

Expand Down