shake 0.17.5 → 0.17.6

raw patch · 48 files changed

+1215/−697 lines, 48 filesdep +filepatterndep +heapsdep ~extraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: filepattern, heaps

Dependency ranges changed: extra

API changes (from Hackage documentation)

Files

• CHANGES.txt +17/−0
• shake.cabal +24/−7
• src/Development/Ninja/All.hs +1/−1
• src/Development/Shake.hs +2/−0
• src/Development/Shake/Command.hs +6/−5
• src/Development/Shake/Forward.hs +51/−16
• src/Development/Shake/Internal/Args.hs +122/−85
• src/Development/Shake/Internal/CompactUI.hs +75/−0
• src/Development/Shake/Internal/Core/Action.hs +70/−26
• src/Development/Shake/Internal/Core/Build.hs +26/−19
• src/Development/Shake/Internal/Core/Rules.hs +53/−9
• src/Development/Shake/Internal/Core/Run.hs +77/−59
• src/Development/Shake/Internal/Core/Types.hs +12/−7
• src/Development/Shake/Internal/Errors.hs +1/−1
• src/Development/Shake/Internal/FileInfo.hs +2/−3
• src/Development/Shake/Internal/History/Shared.hs +36/−33
• src/Development/Shake/Internal/History/Symlink.hs +54/−0
• src/Development/Shake/Internal/Options.hs +20/−10
• src/Development/Shake/Internal/Progress.hs +20/−19
• src/Development/Shake/Internal/Rules/Directory.hs +1/−1
• src/Development/Shake/Internal/Rules/File.hs +21/−9
• src/Development/Shake/Internal/Rules/Files.hs +8/−7
• src/Development/Shake/Internal/Rules/Oracle.hs +1/−1
• src/Development/Shake/Util.hs +1/−1
• src/General/Chunks.hs +12/−13
• src/General/Cleanup.hs +3/−2
• src/General/EscCodes.hs +101/−0
• src/General/Extra.hs +43/−19
• src/General/FileLock.hs +1/−2
• src/General/GetOpt.hs +12/−7
• src/General/Heap.hs +0/−246
• src/General/ListBuilder.hs +3/−1
• src/General/Pool.hs +51/−48
• src/General/Process.hs +1/−1
• src/General/Thread.hs +98/−0
• src/General/Timing.hs +10/−8
• src/Test.hs +4/−1
• src/Test/Docs.hs +1/−0
• src/Test/Errors.hs +3/−2
• src/Test/Forward.hs +4/−5
• src/Test/History.hs +6/−1
• src/Test/Monad.hs +3/−2
• src/Test/Oracle.hs +1/−1
• src/Test/Pool.hs +16/−7
• src/Test/Self.hs +5/−5
• src/Test/Targets.hs +54/−0
• src/Test/Thread.hs +69/−0
• src/Test/Type.hs +13/−7

@@ -1,5 +1,22 @@ Changelog for Shake (* = breaking change) +0.17.6, released 2019-02-17+    Make --progress on Windows work with non-ASCII characters+    #18, add --compact for a Bazel/Buck style output+    Make the progress message display a more traditional count+    #638, add shakeTrace to record start/stop of traced commands+    Show user-added options separately+    #625, make --help show the list of targets+    #625, add addTarget/getTargets to track the available targets+    #416, generalise Forward.cacheAction to be in label and output+    #642, detect files that change with --lint-watch+    #649, add --share-list and --share-remove to work with the cache+    #626, improve the display of error messages with call stacks+    Make sure exceptions don't change based on verbosity setting+    Make sure all thread pool threads terminate before shake returns+    #646, change the identity property to require a Maybe+    Use symlinks for --shared+    #643, add MonadFail Rules 0.17.5, released 2019-02-05     Remove dependency on heaps 0.17.4, released 2019-01-10

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.17.5+version:            0.17.6 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -86,9 +86,11 @@         bytestring,         deepseq >= 1.1,         directory,-        extra >= 1.6.1,+        extra >= 1.6.14,         filepath,+        filepattern,         hashable >= 1.1.2.3,+        heaps >= 0.3.6.1,         js-flot,         js-jquery,         primitive,@@ -134,9 +136,11 @@         Development.Ninja.Type         Development.Shake.Internal.Args         Development.Shake.Internal.CmdOption+        Development.Shake.Internal.CompactUI         Development.Shake.Internal.Core.Action         Development.Shake.Internal.Core.Build         Development.Shake.Internal.History.Shared+        Development.Shake.Internal.History.Symlink         Development.Shake.Internal.History.Bloom         Development.Shake.Internal.History.Cloud         Development.Shake.Internal.History.Network@@ -173,10 +177,10 @@         General.Chunks         General.Cleanup         General.Fence+        General.EscCodes         General.Extra         General.FileLock         General.GetOpt-        General.Heap         General.Ids         General.Intern         General.ListBuilder@@ -184,6 +188,7 @@         General.Pool         General.Process         General.Template+        General.Thread         General.Timing         General.TypeMap         General.Wait@@ -205,9 +210,11 @@         bytestring,         deepseq >= 1.1,         directory,-        extra >= 1.6.1,+        extra >= 1.6.14,         filepath,+        filepattern,         hashable >= 1.1.2.3,+        heaps >= 0.3.6.1,         js-flot,         js-jquery,         primitive,@@ -248,9 +255,11 @@         Development.Shake.FilePath         Development.Shake.Internal.Args         Development.Shake.Internal.CmdOption+        Development.Shake.Internal.CompactUI         Development.Shake.Internal.Core.Action         Development.Shake.Internal.Core.Build         Development.Shake.Internal.History.Shared+        Development.Shake.Internal.History.Symlink         Development.Shake.Internal.History.Bloom         Development.Shake.Internal.History.Cloud         Development.Shake.Internal.History.Network@@ -287,10 +296,10 @@         General.Chunks         General.Cleanup         General.Fence+        General.EscCodes         General.Extra         General.FileLock         General.GetOpt-        General.Heap         General.Ids         General.Intern         General.ListBuilder@@ -298,6 +307,7 @@         General.Pool         General.Process         General.Template+        General.Thread         General.Timing         General.TypeMap         General.Wait@@ -324,9 +334,11 @@         bytestring,         deepseq >= 1.1,         directory,-        extra >= 1.6.1,+        extra >= 1.6.14,         filepath,+        filepattern,         hashable >= 1.1.2.3,+        heaps >= 0.3.6.1,         js-flot,         js-jquery,         primitive,@@ -370,9 +382,11 @@         Development.Shake.Forward         Development.Shake.Internal.Args         Development.Shake.Internal.CmdOption+        Development.Shake.Internal.CompactUI         Development.Shake.Internal.Core.Action         Development.Shake.Internal.Core.Build         Development.Shake.Internal.History.Shared+        Development.Shake.Internal.History.Symlink         Development.Shake.Internal.History.Bloom         Development.Shake.Internal.History.Cloud         Development.Shake.Internal.History.Network@@ -411,10 +425,10 @@         General.Chunks         General.Cleanup         General.Fence+        General.EscCodes         General.Extra         General.FileLock         General.GetOpt-        General.Heap         General.Ids         General.Intern         General.ListBuilder@@ -422,6 +436,7 @@         General.Pool         General.Process         General.Template+        General.Thread         General.Timing         General.TypeMap         General.Wait@@ -467,6 +482,8 @@         Test.Self         Test.SelfMake         Test.Tar+        Test.Targets+        Test.Thread         Test.Tup         Test.Type         Test.Unicode

@@ -231,7 +231,7 @@     deriving Show  printCompDb :: [CompDb] -> String-printCompDb xs = unlines $ ["["] ++ concat (zipWith f [1..] xs) ++ ["]"]+printCompDb xs = unlines $ ["["] ++ concat (zipWithFrom f 1 xs) ++ ["]"]     where         n = length xs         f i CompDb{..} =

@@ -62,6 +62,8 @@     getShakeExtra, getShakeExtraRules, addShakeExtra,     -- ** Command line     shakeArgs, shakeArgsWith, shakeArgsOptionsWith, shakeOptDescrs,+    -- ** Targets+    getTargets, addTarget, withTargetDocs, withoutTargets,     -- ** Progress reporting     Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, getProgress,     -- ** Verbosity

@@ -542,12 +542,15 @@ -- | Execute a system command. Before running 'cmd' make sure you 'Development.Shake.need' any files --   that are used by the command. ----- * @String@ arguments are treated as whitespace separated arguments.+-- * @String@ arguments are treated as a list of whitespace separated arguments. ----- * @[String]@ arguments are treated as literal arguments.+-- * @[String]@ arguments are treated as a list of literal arguments. -- -- * 'CmdOption' arguments are used as options. --+--   Typically only string literals should be passed as @String@ arguments. When using variables+--   prefer @[myvar]@ so that if @myvar@ contains spaces they are properly escaped.+-- --   As some examples, here are some calls, and the resulting command string: -- -- @@@ -561,14 +564,12 @@ --   More examples, including return values, see this translation of the examples given for the 'command' function: -- -- @--- 'cmd_' \"gcc -c myfile.c\"                                         -- compile a file, throwing an exception on failure+-- 'cmd_' \"gcc -c myfile.c\"                                       -- compile a file, throwing an exception on failure -- 'Exit' c <- 'cmd' \"gcc -c\" [myfile]                              -- run a command, recording the exit code -- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\"                -- run a command, recording the exit code and error output -- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\"                         -- run a command, recording the output -- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'Action' ()         -- run a command in a directory -- @------   When passing file arguments we use @[myfile]@ so that if the @myfile@ variable contains spaces they are properly escaped. -- --   If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being --   unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'. If you enable @OverloadedStrings@ or @OverloadedLists@

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}  -- | A module for producing forward-defined build systems, in contrast to standard backwards-defined@@ -48,26 +48,54 @@ import Development.Shake.FilePath import Data.IORef import Data.Either+import Data.Typeable.Extra import Data.List.Extra import Control.Exception.Extra import Numeric import System.IO.Unsafe+import Data.Binary import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as Map+import Data.Functor+import Prelude   {-# NOINLINE forwards #-}-forwards :: IORef (Map.HashMap ForwardQ (Action ()))+forwards :: IORef (Map.HashMap Forward (Action Forward)) forwards = unsafePerformIO $ newIORef Map.empty -newtype ForwardQ = ForwardQ String+-- I'd like to use TypeRep, but it doesn't have any instances in older versions+newtype Forward = Forward (String, String, Wrap BS.ByteString) -- the type, the Show, the payload     deriving (Hashable,Typeable,Eq,NFData,Binary) -type instance RuleResult ForwardQ = ()+-- No NFData ByteString instance until GHC 7.6+newtype Wrap a = Wrap a+    deriving (Hashable,Typeable,Eq,Binary) -instance Show ForwardQ where-    show (ForwardQ x) = x+instance NFData (Wrap a) where+    rnf x = x `seq` () +mkForward :: (Typeable a, Show a, Binary a) => a -> Forward+mkForward x = Forward (show $ typeOf x, show x, Wrap $ encode' x)++unForward :: forall a . (Typeable a, Show a, Binary a) => Forward -> a+unForward (Forward (got,_,Wrap x))+    | got /= want = error $ "Failed to match forward type, wanted " ++ show want ++ ", got " ++ show got+    | otherwise = decode' x+    where want = show $ typeRep (Proxy :: Proxy a)++encode' :: Binary a => a -> BS.ByteString+encode' = BS.concat . LBS.toChunks . encode++decode' :: Binary a => BS.ByteString -> a+decode' = decode . LBS.fromChunks . return++type instance RuleResult Forward = Forward++instance Show Forward where+    show (Forward (_,x,_)) = x+ -- | Run a forward-defined build system. shakeForward :: ShakeOptions -> Action () -> IO () shakeForward opts act = shake (forwardOptions opts) (forwardRule act)@@ -81,13 +109,14 @@ forwardRule act = do     addBuiltinRule noLint noIdentity $ \k old mode ->         case old of-            Just old | mode == RunDependenciesSame -> return $ RunResult ChangedNothing old ()+            Just old | mode == RunDependenciesSame -> return $ RunResult ChangedNothing old (decode' old)             _ -> do                 res <- liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete k mp, Map.lookup k mp)                 case res of-                    Nothing -> liftIO $ errorIO "Failed to find action name"-                    Just act -> act-                return $ RunResult ChangedRecomputeSame BS.empty ()+                    Nothing -> liftIO $ errorIO $ "Failed to find action name, " ++ show k+                    Just act -> do+                        new <- act+                        return $ RunResult ChangedRecomputeSame (encode' new) new     action act  -- | Given a 'ShakeOptions', set the options necessary to execute in forward mode.@@ -96,12 +125,12 @@   -- | Cache an action. The name of the action must be unique for all different actions.-cacheAction :: String -> Action () -> Action ()-cacheAction name action = do-    let key = ForwardQ name-    liftIO $ atomicModifyIORef forwards $ \mp -> (Map.insert key action mp, ())-    _ :: [()] <- apply [key]+cacheAction :: (Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) => a -> Action b -> Action b+cacheAction (mkForward -> key) (action :: Action b) = do+    liftIO $ atomicModifyIORef forwards $ \mp -> (Map.insert key (mkForward <$> action) mp, ())+    res <- apply1 key     liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete key mp, ())+    return $ unForward res  -- | Apply caching to an external command. cache :: (forall r . CmdArguments r => r) -> Action ()@@ -109,4 +138,10 @@     let CmdArgument args = cmd     let isDull ['-',_] = True; isDull _ = False     let name = head $ filter (not . isDull) (drop 1 $ rights args) ++ ["unknown"]-    cacheAction ("command " ++ toStandard name ++ " #" ++ upper (showHex (abs $ hash $ show args) "")) cmd+    cacheAction (Command $ toStandard name ++ " #" ++ upper (showHex (abs $ hash $ show args) "")) cmd++newtype Command = Command String+    deriving (Typeable, Binary)++instance Show Command where+    show (Command x) = "command " ++ x

@@ -11,19 +11,21 @@ import Development.Shake.Internal.Options import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Errors+import Development.Shake.Internal.CompactUI import Development.Shake.Internal.Demo+import Development.Shake.Internal.Core.Action import Development.Shake.FilePath import Development.Shake.Internal.Rules.File import Development.Shake.Internal.Progress import Development.Shake.Database import General.Timing+import General.Thread import General.GetOpt+import General.EscCodes  import Data.Tuple.Extra-import Control.Concurrent import Control.Exception.Extra import Control.Monad-import Data.Char import Data.Either import Data.Functor import Data.List@@ -136,14 +138,16 @@     -> IO () shakeArgsOptionsWith baseOpts userOptions rules = do     addTiming "shakeArgsWith"+    let baseOpts2 = removeOverlap userOptions $ map snd shakeOptsEx     args <- getArgs-    let (flag1,files,errs) = getOpt opts args+    let (flag1,files,errs) = getOpt (baseOpts2 `mergeOptDescr` userOptions) args         (self,user) = partitionEithers flag1         (flagsExtra,flagsShake) = first concat $ unzip self         progressReplays = [x | ProgressReplay x <- flagsExtra]         progressRecords = [x | ProgressRecord x <- flagsExtra]         changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]         printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]+        shareRemoves = [x | ShareRemove x <- flagsExtra]         oshakeOpts = foldl' (flip ($)) baseOpts flagsShake         shakeOpts = oshakeOpts {shakeLintInside = map (toStandard . normalise . addTrailingPathSeparator) $                                                   shakeLintInside oshakeOpts@@ -155,17 +159,30 @@                                }     let putWhen v msg = when (shakeVerbosity oshakeOpts >= v) $ shakeOutput oshakeOpts v msg     let putWhenLn v msg = putWhen v $ msg ++ "\n"-    let showHelp = do+    let showHelp long = do             progName <- getProgName-            putWhen Quiet $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : "Options:" : showOptDescr opts+            extra <- if not long then return [] else do+                -- run the rules as simply as we can+                rs <- rules shakeOpts [] []+                case rs of+                    Just (_, rs) -> do+                        xs <- getTargets shakeOpts rs+                        return $ "" : "Targets:" : ["  - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs]+                    _ -> return [] +            putWhen Quiet $ unlines $+                ("Usage: " ++ progName ++ " [options] [target] ...") :+                (if null baseOpts2 then [] else "" : (if null userOptions then "Options:" else "Standard options:") : showOptDescr baseOpts2) +++                (if null userOptions then [] else "" : "Extra options:" : showOptDescr userOptions) +++                extra+     when (errs /= []) $ do         putWhen Quiet $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs-        showHelp+        showHelp False         exitFailure      if Help `elem` flagsExtra then-        showHelp+        showHelp True      else if Version `elem` flagsExtra then         putWhenLn Normal $ "Shake build system, version " ++ shakeVersionString      else if NumericVersion `elem` flagsExtra then@@ -187,10 +204,8 @@         shakeOpts <- if null progressRecords then return shakeOpts else do             t <- offsetTime             return shakeOpts{shakeProgress = \p ->-                bracket-                    (forkIO $ shakeProgress shakeOpts p)-                    killThread-                    $ const $ progressDisplay 1 (const $ return ()) $ do+                void $ withThreadsBoth (shakeProgress shakeOpts p) $+                    progressDisplay 1 (const $ return ()) $ do                         p <- p                         t <- t                         forM_ progressRecords $ \file ->@@ -201,12 +216,26 @@             when printDirectory $ do                 curdir <- getCurrentDirectory                 putWhenLn Normal $ "shake: In directory `" ++ curdir ++ "'"+            (shakeOpts, ui) <-+                if Compact `elem` flagsExtra+                then second withThreadSlave <$> compactUI shakeOpts+                else return (shakeOpts, id)             rules <- rules shakeOpts user files-            case rules of+            ui $ case rules of                 Nothing -> return (False, shakeOpts, Right ())                 Just (shakeOpts, rules) -> do                     res <- try_ $ shake shakeOpts $-                        if NoBuild `elem` flagsExtra then withoutActions rules else rules+                        if NoBuild `elem` flagsExtra then+                            withoutActions rules+                        else if ShareList `elem` flagsExtra || not (null shareRemoves) then do+                            action $ do+                                unless (null shareRemoves) $+                                    actionShareRemove shareRemoves+                                when (ShareList `elem` flagsExtra)+                                    actionShareList+                            withoutActions rules+                        else+                            rules                     return (True, shakeOpts, res)          if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then@@ -218,13 +247,11 @@                     if Exception `elem` flagsExtra then                         throwIO err                     else do-                        putWhenLn Quiet $ esc "31" $ show err+                        putWhenLn Quiet $ esc Red $ show err                         exitFailure                 Right () -> do                     tot <- start-                    putWhenLn Normal $ esc "32" $ "Build completed in " ++ showDuration tot-    where-        opts = removeOverlap userOptions (map snd shakeOptsEx) `mergeOptDescr` userOptions+                    putWhenLn Normal $ esc Green $ "Build completed in " ++ showDuration tot   -- | A list of command line options that can be used to modify 'ShakeOptions'. Each option returns@@ -232,7 +259,7 @@ --   in 'ShakeOptions'. The command line flags are @make@ compatible where possbile, but additional --   flags have been added for the extra options Shake supports. shakeOptDescrs :: [OptDescr (Either String (ShakeOptions -> ShakeOptions))]-shakeOptDescrs = [fmapOptDescr snd o | (True, o) <- shakeOptsEx]+shakeOptDescrs = [fmapFmapOptDescr snd o | (True, o) <- shakeOptsEx]  data Extra = ChangeDirectory FilePath            | Version@@ -246,102 +273,110 @@            | ProgressRecord FilePath            | ProgressReplay FilePath            | Demo+           | ShareList+           | ShareRemove String+           | Compact              deriving Eq  -unescape :: String -> String-unescape ('\ESC':'[':xs) = unescape $ drop 1 $ dropWhile (not . isAlpha) xs-unescape (x:xs) = x : unescape xs-unescape [] = []--escape :: String -> String -> String-escape code x = "\ESC[" ++ code ++ "m" ++ x ++ "\ESC[0m"+escape :: Color -> String -> String+escape color x = escForeground color ++ x ++ escNormal  outputColor :: (Verbosity -> String -> IO ()) -> Verbosity -> String -> IO ()-outputColor output v msg = output v $ escape "34" msg+outputColor output v msg = output v $ escape Blue msg  -- | True if it has a potential effect on ShakeOptions shakeOptsEx :: [(Bool, OptDescr (Either String ([Extra], ShakeOptions -> ShakeOptions)))] shakeOptsEx =-    [yes $ Option "a" ["abbrev"] (pairArg "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages."-    ,no  $ Option ""  ["no-build"] (NoArg $ Right ([NoBuild], id)) "Don't build anything."-    ,no  $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything."-    ,yes $ Option ""  ["cloud"] (reqArg "URL" $ \x s -> s{shakeCloud=shakeCloud s ++ [x]}) "HTTP server providing a cloud cache."-    ,yes $ Option ""  ["color","colour"] (noArg $ \s -> s{shakeColor=True}) "Colorize the output."-    ,no  $ Option ""  ["no-color","no-colour"] (noArg $ \s -> s{shakeColor=False}) "Don't colorize the output."-    ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."-    ,no  $ Option ""  ["demo"] (NoArg $ Right ([Demo], id)) "Run in demo mode."-    ,yes $ Option ""  ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes."-    ,yes $ Option ""  ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change."-    ,yes $ Option ""  ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."-    ,yes $ Option ""  ["digest-or"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeOrDigest})) "Files change when modtime or digest change."-    ,yes $ Option ""  ["digest-not"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtime})) "Files change when modtime changes."-    ,no  $ Option ""  ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."-    ,yes $ Option ""  ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."-    ,yes $ Option ""  ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."-    ,no  $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."-    ,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."-    ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."-    ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."-    ,yes $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."-    ,yes $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."-    ,yes $ Option ""  ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."-    ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."-    ,no  $ Option ""  ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit."-    ,yes $ Option ""  ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."-    ,yes $ Option ""  ["rebuild"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNow, fromMaybe "**" x)]})) "PATTERN") "Rebuild matching files."-    ,yes $ Option ""  ["no-rebuild"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNormal, fromMaybe "**" x)]})) "PATTERN") "Rebuild matching files if necessary (default)."-    ,yes $ Option ""  ["skip"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildLater, fromMaybe "**" x)]})) "PATTERN") "Don't rebuild matching files this run."+    [opts $ Option "a" ["abbrev"] (reqArgPair "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages."+    ,extr $ Option ""  ["no-build"] (noArg [NoBuild]) "Don't build anything."+    ,extr $ Option "C" ["directory"] (reqArg "DIRECTORY" $ \x -> [ChangeDirectory x]) "Change to DIRECTORY before doing anything."+--    ,yes $ Option ""  ["cloud"] (reqArg "URL" $ \x s -> s{shakeCloud=shakeCloud s ++ [x]}) "HTTP server providing a cloud cache."+    ,opts $ Option ""  ["color","colour"] (noArg $ \s -> s{shakeColor=True}) "Colorize the output."+    ,opts $ Option ""  ["no-color","no-colour"] (noArg $ \s -> s{shakeColor=False}) "Don't colorize the output."+    ,extr $ Option ""  ["compact"] (noArg [Compact]) "Use a compact Bazel/Buck style output."+    ,opts $ Option "d" ["debug"] (optArg "FILE" $ \x s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x}) "Print lots of debugging information."+    ,extr  $ Option ""  ["demo"] (noArg [Demo]) "Run in demo mode."+    ,opts $ Option ""  ["digest"] (noArg $ \s -> s{shakeChange=ChangeDigest}) "Files change when digest changes."+    ,opts $ Option ""  ["digest-and"] (noArg $ \s -> s{shakeChange=ChangeModtimeAndDigest}) "Files change when modtime and digest change."+    ,opts $ Option ""  ["digest-and-input"] (noArg $ \s -> s{shakeChange=ChangeModtimeAndDigestInput}) "Files change on modtime (and digest for inputs)."+    ,opts $ Option ""  ["digest-or"] (noArg $ \s -> s{shakeChange=ChangeModtimeOrDigest}) "Files change when modtime or digest change."+    ,opts $ Option ""  ["digest-not"] (noArg $ \s -> s{shakeChange=ChangeModtime}) "Files change when modtime changes."+    ,extr $ Option ""  ["exception"] (noArg [Exception]) "Throw exceptions directly."+    ,opts $ Option ""  ["flush"] (reqIntArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."+    ,opts $ Option ""  ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."+    ,extr $ Option "h" ["help"] (noArg [Help]) "Print this message and exit."+    ,opts $ Option "j" ["jobs"] (optArgInt 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."+    ,opts $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."+    ,opts $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."+    ,opts $ Option ""  ["lint-watch"] (reqArg "PATTERN" $ \x s -> s{shakeLintWatch=shakeLintWatch s ++ [x]}) "Error if any of the patterns are created (expensive)."+    ,opts $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."+    ,opts $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."+    ,opts $ Option ""  ["live"] (optArg "FILE" $ \x s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]}) "List the files that are live [to live.txt]."+    ,opts $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."+    ,extr $ Option ""  ["numeric-version"] (noArg [NumericVersion]) "Print just the version number and exit."+    ,opts $ Option ""  ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."+    ,opts $ Option ""  ["rebuild"] (optArg "PATTERN" $ \x s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNow, fromMaybe "**" x)]}) "Rebuild matching files."+    ,opts $ Option ""  ["no-rebuild"] (optArg "PATTERN" $ \x s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNormal, fromMaybe "**" x)]}) "Rebuild matching files if necessary (default)."+    ,opts $ Option ""  ["skip"] (optArg "PATTERN" $ \x s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildLater, fromMaybe "**" x)]}) "Don't rebuild matching files this run." --    ,yes $ Option ""  ["skip-forever"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNever, fromMaybe "**" x)]})) "PATTERN") "Don't rebuild matching files until they change."-    ,yes $ Option "r" ["report","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."-    ,yes $ Option ""  ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."-    ,yes $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."-    ,yes $ Option ""  ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."-    ,yes $ Option ""  ["share"] (OptArg (\x -> Right ([], \s -> s{shakeShare=Just $ fromMaybe "" x, shakeChange=ensureHash $ shakeChange s})) "DIRECTORY") "Shared cache location."-    ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."-    ,no  $ Option ""  ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."-    ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."-    ,yes $ Option ""  ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."-    ,yes $ Option "p" ["progress"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]."-    ,yes $ Option ""  ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."-    ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Print less (pass repeatedly for even less)."-    ,no  $ Option ""  ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."-    ,yes $ Option ""  ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."-    ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print more (pass repeatedly for even more)."-    ,no  $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit."-    ,no  $ Option "w" ["print-directory"] (NoArg $ Right ([PrintDirectory True],id)) "Print the current directory."-    ,no  $ Option ""  ["no-print-directory"] (NoArg $ Right ([PrintDirectory False],id)) "Turn off -w, even if it was turned on implicitly."+    ,opts $ Option "r" ["report","profile"] (optArg "FILE" $ \x s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]}) "Write out profiling information [to report.html]."+    ,opts $ Option ""  ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."+    ,opts $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."+    ,opts $ Option ""  ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."+    ,opts $ Option ""  ["share"] (optArg "DIRECTORY" $ \x s -> s{shakeShare=Just $ fromMaybe "" x, shakeChange=ensureHash $ shakeChange s}) "Shared cache location."+    ,hide  $ Option ""  ["share-list"] (noArg ([ShareList], ensureShare)) "List the shared cache files."+    ,hide $ Option ""  ["share-remove"] (OptArg (\x -> Right ([ShareRemove $ fromMaybe "**" x], ensureShare)) "SUBSTRING") "Remove the shared cache keys."+    ,opts $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."+    ,extr $ Option ""  ["sleep"] (noArg [Sleep]) "Sleep for a second before building."+    ,opts $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."+    ,opts $ Option ""  ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."+    ,both $ Option "p" ["progress"] (progress $ optArgInt 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]."+    ,opts $ Option ""  ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."+    ,opts $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Print less (pass repeatedly for even less)."+    ,extr $ Option ""  ["no-time"] (noArg [NoTime]) "Don't print build time."+    ,opts $ Option ""  ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."+    ,opts $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print more (pass repeatedly for even more)."+    ,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."     ]     where-        yes = (,) True-        no  = (,) False+        opts o = (True, fmapFmapOptDescr ([],) o)+        extr o = (False, fmapFmapOptDescr (,id) o)+        both o = (True, o)+        hide o = (False, o) -- I do modify the options, but not in a meaningful way          move :: Verbosity -> (Int -> Int) -> Verbosity         move x by = toEnum $ min (fromEnum mx) $ max (fromEnum mn) $ by $ fromEnum x             where (mn,mx) = (asTypeOf minBound x, asTypeOf maxBound x) -        noArg f = NoArg $ Right ([], f)-        reqArg a f = ReqArg (\x -> Right ([], f x)) a-        intArg mn flag a f = flip ReqArg a $ \x -> case reads x of-            [(i,"")] | i >= mn -> Right ([],f i)+        noArg = NoArg . Right+        reqArg a f = ReqArg (Right . f) a+        optArg a f = OptArg (Right . f) a++        reqIntArg mn flag a f = flip ReqArg a $ \x -> case reads x of+            [(i,"")] | i >= mn -> Right (f i)             _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"-        optIntArg mn flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of-            [(i,"")] | i >= mn -> Right ([],f $ Just i)++        optArgInt mn flag a f = flip OptArg a $ maybe (Right (f Nothing)) $ \x -> case reads x of+            [(i,"")] | i >= mn -> Right (f $ Just i)             _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"-        pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of-            (a,'=':b) -> Right ([],f (a,b))++        reqArgPair flag a f = flip ReqArg a $ \x -> case break (== '=') x of+            (a,'=':b) -> Right $ f (a,b)             _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"          progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of             Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)             Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)-            _ -> func x+            _ -> ([],) <$> func x         progress _ = throwImpure $ errorInternal "incomplete pattern, progress"          outputDebug output Nothing = output         outputDebug output (Just file) = \v msg -> do             when (v /= Diagnostic) $ output v msg-            appendFile file $ unescape msg ++ "\n"+            appendFile file $ removeEscCodes msg ++ "\n"          prog i p = do             program <- progressProgram@@ -351,3 +386,5 @@         ensureHash ChangeModtime = ChangeModtimeAndDigest         ensureHash ChangeModtimeAndDigestInput = ChangeModtimeAndDigest         ensureHash x = x++        ensureShare s = s{shakeShare = Just $ fromMaybe "." $ shakeShare s}

@@ -0,0 +1,75 @@++-- | Provide a Buck/Bazel style UI.+module Development.Shake.Internal.CompactUI(+    compactUI+    ) where++import Development.Shake.Internal.Options+import Development.Shake.Internal.Progress++import System.Time.Extra+import General.Extra+import Control.Exception+import General.Thread+import General.EscCodes+import Data.IORef+import Control.Monad.Extra+++data S = S+    {sOutput :: [String] -- ^ Messages that haven't yet been printed, in reverse.+    ,sProgress :: String -- ^ Last progress message.+    ,sTraces :: [Maybe (String, String, Seconds)] -- ^ the traced items, in the order we display them+    ,sUnwind :: Int -- ^ Number of lines we used last time around+    }++emptyS = S [] "Starting..." [] 0++addOutput pri msg s = s{sOutput = msg : sOutput s}+addProgress x s = s{sProgress = x}++addTrace key msg start time s+    | start = s{sTraces = insert (key,msg,time) $ sTraces s}+    | otherwise = s{sTraces = remove (\(a,b,_) -> a == key && b == msg) $ sTraces s}+    where+        insert v (Nothing:xs) = Just v:xs+        insert v (x:xs) = x : insert v xs+        insert v [] = [Just v]++        remove f (Just x:xs) | f x = Nothing:xs+        remove f (x:xs) = x : remove f xs+        remove f [] = []+++display :: Seconds -> S -> (S, String)+display time s = (s{sOutput=[], sUnwind=length post}, escCursorUp (sUnwind s) ++ unlines (map pad $ pre ++ post))+    where+        pre = sOutput s+        post = "" : (escForeground Green ++ "Status: " ++ sProgress s ++ escNormal) : map f (sTraces s)++        pad x = x ++ escClearLine+        f Nothing = " *"+        f (Just (k,m,t)) = " * " ++ k ++ " (" ++ g (time - t) m ++ ")"++        g i m | showDurationSecs i == "0s" = m+              | i < 10 = s+              | otherwise = escForeground (if i > 20 then Red else Yellow) ++ s ++ escNormal+            where s = m ++ " " ++ showDurationSecs i+++-- | Run a compact UI, with the ShakeOptions modifier, combined with+compactUI :: ShakeOptions -> IO (ShakeOptions, IO ())+compactUI opts = do+    unlessM checkEscCodes $+        putStrLn "Your terminal does not appear to support escape codes, --compact mode may not work"+    ref <- newIORef emptyS+    let tweak f = atomicModifyIORef ref $ \s -> (f s, ())+    time <- offsetTime+    opts <- return $ opts+        {shakeTrace = \a b c -> do t <- time;  tweak (addTrace a b c t)+        ,shakeOutput = \a b -> tweak (addOutput a b)+        ,shakeProgress = \x -> void $ progressDisplay 1 (tweak . addProgress) x `withThreadsBoth` shakeProgress opts x+        ,shakeVerbosity = Quiet+        }+    let tick = do t <- time; mask_ $ putStr =<< atomicModifyIORef ref (display t)+    return (opts, forever (tick >> sleep 0.4) `finally` tick)

@@ -15,9 +15,10 @@     historyDisable,     traced,     -- Internal only-    producesUnchecked, producesCheck, lintCurrentDirectory,+    producesUnchecked, producesCheck, lintCurrentDirectory, lintWatch,     blockApply, unsafeAllowApply, shakeException, lintTrackFinished,-    getCurrentKey+    getCurrentKey,+    actionShareList, actionShareRemove     ) where  import Control.Exception@@ -27,6 +28,8 @@ import Control.DeepSeq import Data.Typeable.Extra import System.Directory+import System.FilePattern+import System.FilePattern.Directory import Data.Function import Control.Concurrent.Extra import Data.Maybe@@ -43,11 +46,14 @@  import Development.Shake.Classes import Development.Shake.Internal.Core.Monad+import Development.Shake.Internal.History.Shared import General.Pool import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Core.Pool import Development.Shake.Internal.Value+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.FileName import Development.Shake.Internal.Options import Development.Shake.Internal.Errors import General.Cleanup@@ -77,8 +83,8 @@ --   If the exception is already a ShakeException (e.g. it's a child of ours who failed and we are rethrowing) --   then do nothing with it. shakeException :: Global -> Stack -> SomeException -> IO ShakeException-shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of-    Just e@ShakeException{} -> return e+shakeException Global{globalOptions=ShakeOptions{..},..} stk e = case fromException e of+    Just (e :: ShakeException) -> return e     Nothing -> do         e <- return $ exceptionStack stk e         when (shakeStaunch && shakeVerbosity >= Quiet) $@@ -231,8 +237,11 @@     Global{..} <- Action getRO     Local{localStack} <- Action getRW     start <- liftIO globalTimestamp-    putNormal $ "# " ++ msg ++ " (for " ++ showTopStack localStack ++ ")"-    res <- liftIO act+    let key = showTopStack localStack+    putNormal $ "# " ++ msg ++ " (for " ++ key ++ ")"+    res <- liftIO $+        (shakeTrace globalOptions key msg True >> act)+            `finally` shakeTrace globalOptions key msg False     stop <- liftIO globalTimestamp     let trace = newTrace msg start stop     liftIO $ evaluate $ rnf trace@@ -267,29 +276,29 @@  lintTrackFinished :: Action () lintTrackFinished = do+    -- only called when isJust shakeLint     Global{..} <- Action getRO-    when (isJust $ shakeLint globalOptions) $ do-        Local{..} <- Action getRW-        liftIO $ do-            deps <- concatMapM (listDepends globalDatabase) localDepends+    Local{..} <- Action getRW+    liftIO $ do+        deps <- concatMapM (listDepends globalDatabase) localDepends -            -- check 4a-            bad <- return $ localTrackUsed \\ deps-            unless (null bad) $ do-                let n = length bad-                throwM $ errorStructured-                    ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")-                    [("Used", Just $ show x) | x <- bad]-                    ""+        -- check 4a+        bad <- return $ localTrackUsed \\ deps+        unless (null bad) $ do+            let n = length bad+            throwM $ errorStructured+                ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")+                [("Used", Just $ show x) | x <- bad]+                "" -            -- check 4b-            bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k-            unless (null bad) $ do-                let n = length bad-                throwM $ errorStructured-                    ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")-                    [("Used", Just $ show x) | x <- bad]-                    ""+        -- check 4b+        bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k+        unless (null bad) $ do+            let n = length bad+            throwM $ errorStructured+                ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")+                [("Used", Just $ show x) | x <- bad]+                ""   -- | Track that a key has been changed/written by the action preceding it when 'shakeLint' is active.@@ -332,7 +341,25 @@         ,("Got",Just now)]         "" +lintWatch :: [FilePattern] -> IO (String -> IO ())+lintWatch [] = return $ const $ return ()+lintWatch pats = do+    let op = getDirectoryFiles "." pats -- cache parsing of the pats+    let record = do xs <- op; forM xs $ \x -> (x,) <$> getFileInfo (fileNameFromString x)+    old <- record+    return $ \msg -> do+        now <- record+        when (old /= now) $ throwIO $ errorStructured+            "Lint checking error - watched files have changed"+            (("When", Just msg) : changes (Map.fromList old) (Map.fromList now))+            ""+    where+        changes old now =+            [("Created", Just x) | x <- Map.keys $ Map.difference now old] +++            [("Deleted", Just x) | x <- Map.keys $ Map.difference old now] +++            [("Changed", Just x) | x <- Map.keys $ Map.filter id $ Map.intersectionWith (/=) old now] + listDepends :: Var Database -> Depends -> IO [Key] listDepends db (Depends xs) = withVar db $ \Database{..} ->     -- FIXME: Don't actually need the database lock to do this as the results are stable@@ -541,3 +568,20 @@  getCurrentKey :: Action (Maybe Key) getCurrentKey = Action $ topStack . localStack <$> getRW+++-- | Hooked up to --share-remove+actionShareRemove :: [String] -> Action ()+actionShareRemove substrs = do+    Global{..} <- Action getRO+    case globalShared of+        Nothing -> throwM $ errorInternal "actionShareRemove with no shared"+        Just x -> liftIO $ removeShared x $ \k -> any (`isInfixOf` show k) substrs++-- | Hooked up to --share-list+actionShareList :: Action ()+actionShareList = do+    Global{..} <- Action getRO+    case globalShared of+        Nothing -> throwM $ errorInternal "actionShareList with no shared"+        Just x -> liftIO $ listShared x

@@ -171,7 +171,7 @@ applyKeyValue callStack ks = do     global@Global{..} <- Action getRO     Local{localStack} <- Action getRW-    let stack = addCallStack (if shakeVerbosity globalOptions > Normal then callStack else take 1 callStack) localStack+    let stack = addCallStack callStack localStack      (is, wait) <- liftIO $ runLocked globalDatabase $ \database -> do         is <- mapM (getKeyId database) ks@@ -216,13 +216,13 @@         liftIO $ evaluate $ rnf res          -- completed, now track anything required afterwards-        lintTrackFinished-        producesCheck+        when (runChanged res `elem` [ChangedRecomputeSame,ChangedRecomputeDiff]) $ do+            -- if the users code didn't run you don't have to check anything (we assume builtin rules are correct)+            globalRuleFinished k+            producesCheck          Action $ fmap (res,) getRW) $ \x -> case x of-            Left e -> do-                e <- if isNothing shakeLint then return e else handle return $-                    do lintCurrentDirectory globalCurDir $ "Running " ++ show k; return e+            Left e ->                 continue . Left . toException =<< shakeException global stack e             Right (RunResult{..}, Local{..})                 | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->@@ -284,7 +284,7 @@         res <- liftIO $ runLocked globalDatabase $ \database -> runWait $ do             let ask k = do                     i <- quickly $ getKeyId database k-                    let identify = Just . runIdentify globalRules k . fst . result+                    let identify = runIdentify globalRules k . fst . result                     either (const Nothing) identify <$> lookupOne global localStack database i             x <- case globalShared of                 Nothing -> return Nothing@@ -317,11 +317,15 @@                 return (Just res)  --- | Is the history enabled.+-- | Is the history enabled, returns 'True' if you have a 'shakeShare' or 'shakeCloud',+--   and haven't called 'historyDisable' so far in this rule. historyIsEnabled :: Action Bool-historyIsEnabled = Action $-    (isJust . globalShared <$> getRO) &&^ (localHistory <$> getRW)+historyIsEnabled = Action $ do+    Global{..} <- getRO+    Local{localHistory} <- getRW+    return $ localHistory && (isJust globalShared || isJust globalCloud) + -- | Save a value to the history. Record the version of any user rule --   (or @0@), and a payload. Must be run at the end of the rule, after --   any dependencies have been captured. If history is enabled, stores the information@@ -330,10 +334,10 @@ --   This function relies on 'produces' to have been called correctly to describe --   which files were written during the execution of this rule. historySave :: Int -> BS.ByteString -> Action ()-historySave (Ver -> ver) store = Action $ do+historySave (Ver -> ver) store = whenM historyIsEnabled $ Action $ do     Global{..} <- getRO-    Local{localHistory, localProduces, localDepends, localBuiltinVersion, localStack} <- getRW-    liftIO $ when (localHistory && (isJust globalShared || isJust globalCloud)) $ do+    Local{localProduces, localDepends, localBuiltinVersion, localStack} <- getRW+    liftIO $ do         -- make sure we throw errors before we get into the history         evaluate ver         evaluate store@@ -342,16 +346,19 @@         let produced = reverse $ map snd localProduces         deps <- runLocked globalDatabase $ \database ->             -- technically this could be run without the DB lock, since it reads things that are stable-            forM (reverse localDepends) $ \(Depends is) -> forM is $ \i -> do+            forNothingM (reverse localDepends) $ \(Depends is) -> forNothingM is $ \i -> do                 Just (k, Ready r) <- getIdKeyStatus database i-                return (k, runIdentify globalRules k $ fst $ result r)+                return $ (k,) <$> runIdentify globalRules k (fst $ result r)         let k = topStack localStack-        whenJust globalShared $ \shared -> addShared shared key localBuiltinVersion ver deps store produced-        whenJust globalCloud  $ \cloud  -> addCloud  cloud  key localBuiltinVersion ver deps store produced-        liftIO $ globalDiagnostic $ return $ "History saved for " ++ show k+        case deps of+            Nothing -> liftIO $ globalDiagnostic $ return $ "Dependency with no identity for " ++ show k+            Just deps -> do+                whenJust globalShared $ \shared -> addShared shared key localBuiltinVersion ver deps store produced+                whenJust globalCloud  $ \cloud  -> addCloud  cloud  key localBuiltinVersion ver deps store produced+                liftIO $ globalDiagnostic $ return $ "History saved for " ++ show k  -runIdentify :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> BS.ByteString+runIdentify :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> Maybe BS.ByteString runIdentify mp k v     | Just BuiltinRule{..} <- Map.lookup (typeKey k) mp = builtinIdentity k v     | otherwise = throwImpure $ errorInternal "runIdentify can't find rule"

@@ -1,7 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}  module Development.Shake.Internal.Core.Rules(     Rules, runRules,@@ -10,6 +11,7 @@     getShakeOptionsRules,     getUserRuleInternal, getUserRuleOne, getUserRuleList, getUserRuleMaybe,     addUserRule, alternatives, priority, versioned,+    getTargets, addTarget, withTargetDocs, withoutTargets,     action, withoutActions     ) where @@ -24,6 +26,7 @@ import General.Binary import General.Extra import Data.Typeable.Extra+import Data.Data import Data.Function import Data.List.Extra import qualified Data.HashMap.Strict as Map@@ -39,6 +42,10 @@ import Data.Binary.Get import General.ListBuilder +#if __GLASGOW_HASKELL__ >= 800+import Control.Monad.Fail+#endif+ import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Monad import Development.Shake.Internal.Value@@ -110,7 +117,11 @@ --   Rules are combined with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation. --   To define your own custom types of rule, see "Development.Shake.Rule". newtype Rules a = Rules (ReaderT (ShakeOptions, IORef SRules) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)-    deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+    deriving (Functor, Applicative, Monad, MonadIO, MonadFix+#if __GLASGOW_HASKELL__ >= 800+             ,MonadFail+#endif+        )  newRules :: SRules -> Rules () newRules x = Rules $ liftIO . flip modifyIORef' (<> x) =<< asks snd@@ -125,25 +136,41 @@         modifyIORef' refOld (<> f rules)         return res -runRules :: ShakeOptions -> Rules () -> IO ([(Stack, Action ())], Map.HashMap TypeRep BuiltinRule, TMap.Map UserRuleVersioned)+runRules :: ShakeOptions -> Rules () -> IO ([(Stack, Action ())], Map.HashMap TypeRep BuiltinRule, TMap.Map UserRuleVersioned, [Target]) runRules opts (Rules r) = do     ref <- newIORef mempty     runReaderT r (opts, ref)     SRules{..} <- readIORef ref-    return (runListBuilder actions, builtinRules, userRules)+    return (runListBuilder actions, builtinRules, userRules, runListBuilder targets) +-- | Get all targets registered in the given rules. The names in+--   'Development.Shake.phony' and 'Development.Shake.~>' as well as the file patterns+--   in 'Development.Shake.%>', 'Development.Shake.|%>' and 'Development.Shake.&%>' are+--   registered as targets, plus any explicit calls to 'addTarget'.+--   Returns the command, paired with the documentation (if any).+getTargets :: ShakeOptions -> Rules () -> IO [(String, Maybe String)]+getTargets opts rs = do+    (_actions, _ruleinfo, _userRules, targets) <- runRules opts rs+    return [(target, documentation) | Target{..} <- targets]++data Target = Target+    {target :: !String+    ,documentation :: !(Maybe String)+    } deriving (Eq,Ord,Show,Read,Data,Typeable)+ data SRules = SRules     {actions :: !(ListBuilder (Stack, Action ()))     ,builtinRules :: !(Map.HashMap TypeRep{-k-} BuiltinRule)     ,userRules :: !(TMap.Map UserRuleVersioned)+    ,targets :: !(ListBuilder Target)     }  instance Semigroup SRules where-    (SRules x1 x2 x3) <> (SRules y1 y2 y3) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3)+    (SRules x1 x2 x3 x4) <> (SRules y1 y2 y3 y4) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3) (mappend x4 y4)         where f k a b = throwImpure $ errorRuleDefinedMultipleTimes k [builtinLocation a, builtinLocation b]  instance Monoid SRules where-    mempty = SRules mempty Map.empty TMap.empty+    mempty = SRules mempty Map.empty TMap.empty mempty     mappend = (<>)  instance Semigroup a => Semigroup (Rules a) where@@ -159,6 +186,25 @@ addUserRule :: Typeable a => a -> Rules () addUserRule r = newRules mempty{userRules = TMap.singleton $ UserRuleVersioned False $ UserRule r} +-- | Register a target, as available when passing @--help@ or through 'getTargets'.+--   Called automatically by rules such as 'Development.Shake.phony' and+--   'Development.Shake.%>' - to avoid that use 'withoutTargets'.+--   To add documentation to a target use 'withTargetDocs'.+addTarget :: String -> Rules ()+addTarget t = newRules mempty{targets = newListBuilder $ Target t Nothing}++-- | For all 'addTarget' targets within the 'Rules' prodivde the specified documentation, if they+--   don't already have documentation.+withTargetDocs :: String -> Rules () -> Rules ()+withTargetDocs d = modifyRulesScoped $ \x -> x{targets = f <$> targets x}+    where f (Target a b) = Target a $ Just $ fromMaybe d b++-- | Remove all targets specified in a set of rules, typically because they are internal details.+--   Overrides 'addTarget'.+withoutTargets :: Rules a -> Rules a+withoutTargets = modifyRulesScoped $ \x -> x{targets=mempty}++ -- | A suitable 'BuiltinLint' that always succeeds. noLint :: BuiltinLint key value noLint _ _ = return Nothing@@ -167,9 +213,7 @@ --   Use this function if you don't care about 'shakeShare', or if your rule provides a dependency that can --   never be cached (in which case you should also call 'Development.Shake.historyDisable'). noIdentity :: Typeable key => BuiltinIdentity key value-noIdentity k _ = throwImpure $ errorStructured-    "Key type does not support BuiltinIdentity, so does not work with 'shakeShare'"-    [("Key type", Just $ show (typeOf k))] []+noIdentity _ _ = Nothing   -- | The type mapping between the @key@ or a rule and the resulting @value@.

@@ -17,6 +17,7 @@ import Control.Applicative import Data.Tuple.Extra import Control.Concurrent.Extra hiding (withNumCapabilities)+import Control.Monad.IO.Class import General.Binary import Development.Shake.Internal.Core.Storage import Development.Shake.Internal.History.Shared@@ -50,6 +51,7 @@ import Development.Shake.Internal.Options import Development.Shake.Internal.Errors import General.Timing+import General.Thread import General.Extra import General.Cleanup import Data.Monoid@@ -73,7 +75,7 @@ open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState open cleanup opts rs = withInit opts $ \opts@ShakeOptions{..} diagnostic _ -> do     diagnostic $ return "Starting run"-    (actions, ruleinfo, userRules) <- runRules opts rs+    (actions, ruleinfo, userRules, _targets) <- runRules opts rs      diagnostic $ return $ "Number of actions = " ++ show (length actions)     diagnostic $ return $ "Number of builtin rules = " ++ show (Map.size ruleinfo) ++ " " ++ show (Map.keys ruleinfo)@@ -101,66 +103,88 @@  run :: RunState -> Bool -> [Action ()] -> IO [IO ()] run RunState{..} oneshot actions2 =-    withCleanup $ \cleanup -> withInit opts $ \opts@ShakeOptions{..} diagnostic output -> do-        register cleanup $ do-            when (shakeTimings && shakeVerbosity >= Normal) printTimings-            resetTimings -- so we don't leak memory+    withInit opts $ \opts@ShakeOptions{..} diagnostic output -> do -        start <- offsetTime-        database <- readVar databaseVar-        except <- newIORef (Nothing :: Maybe (String, ShakeException))-        let getFailure = fmap fst <$> readIORef except-        let raiseError err-                | not shakeStaunch = throwIO err-                | otherwise = do-                    let named = shakeAbbreviationsApply opts . shakeExceptionTarget-                    atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())-                    -- no need to print exceptions here, they get printed when they are wrapped+        -- timings are a bit delicate, we want to make sure we clear them before we leave (so each run is fresh)+        -- but we also want to only print them if there is no exception, and have to caputre them before we clear them+        -- we use this variable to stash them away, then print after the exception handling block+        timingsToShow <- newIORef Nothing -        after <- newIORef []-        absent <- newIORef []-        step <- incrementStep database-        getProgress <- usingProgress cleanup opts database step getFailure-        lintCurrentDirectory curdir "When running"+        res <- withCleanup $ \cleanup -> do+            register cleanup $ do+                when (shakeTimings && shakeVerbosity >= Normal) $+                    writeIORef timingsToShow . Just =<< getTimings+                resetTimings -        addTiming "Running rules"-        runPool (shakeThreads == 1) shakeThreads $ \pool -> do-            let global = Global databaseVar pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules shared cloud step oneshot-            -- give each action a stack to start with!-            forM_ (actions ++ map (emptyStack,) actions2) $ \(stack, act) -> do-                let local = newLocal stack shakeVerbosity-                addPool PoolStart pool $ runAction global local act $ \x -> case x of-                    Left e -> raiseError =<< shakeException global stack e-                    Right x -> return x-        maybe (return ()) (throwIO . snd) =<< readIORef except-        assertFinishedDatabase database+            start <- offsetTime+            database <- readVar databaseVar+            except <- newIORef (Nothing :: Maybe (String, ShakeException))+            let getFailure = fmap fst <$> readIORef except+            let raiseError err+                    | not shakeStaunch = throwIO err+                    | otherwise = do+                        let named = shakeAbbreviationsApply opts . shakeExceptionTarget+                        atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())+                        -- no need to print exceptions here, they get printed when they are wrapped -        let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg+            after <- newIORef []+            absent <- newIORef []+            step <- incrementStep database+            getProgress <- usingProgress cleanup opts database step getFailure+            lintCurrentDirectory curdir "When running" -        when (null actions && null actions2) $-            putWhen Normal "Warning: No want/action statements, nothing to do"+            watch <- lintWatch shakeLintWatch+            let ruleFinished+                    | isJust shakeLint = \k -> do+                        liftIO $ lintCurrentDirectory curdir $ show k+                        lintTrackFinished+                        liftIO $ watch $ show k+                    | otherwise = liftIO . watch . show -        when (isJust shakeLint) $ do-            addTiming "Lint checking"-            lintCurrentDirectory curdir "After completion"-            checkValid diagnostic database (runLint ruleinfo) =<< readIORef absent-            putWhen Loud "Lint checking succeeded"-        when (shakeReport /= []) $ do-            addTiming "Profile report"-            forM_ shakeReport $ \file -> do-                putWhen Normal $ "Writing report to " ++ file-                writeProfile file database-        when (shakeLiveFiles /= []) $ do-            addTiming "Listing live"-            diagnostic $ return "Listing live keys"-            xs <- liveFiles database-            forM_ shakeLiveFiles $ \file -> do-                putWhen Normal $ "Writing live list to " ++ file-                (if file == "-" then putStr else writeFile file) $ unlines xs+            addTiming "Running rules"+            runPool (shakeThreads == 1) shakeThreads $ \pool -> do+                let global = Global databaseVar pool cleanup start ruleinfo output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot+                -- give each action a stack to start with!+                forM_ (actions ++ map (emptyStack,) actions2) $ \(stack, act) -> do+                    let local = newLocal stack shakeVerbosity+                    addPool PoolStart pool $ runAction global local act $ \x -> case x of+                        Left e -> raiseError =<< shakeException global stack e+                        Right x -> return x+            maybe (return ()) (throwIO . snd) =<< readIORef except+            assertFinishedDatabase database -        readIORef after+            let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg +            when (null actions && null actions2) $+                putWhen Normal "Warning: No want/action statements, nothing to do" +            when (isJust shakeLint) $ do+                addTiming "Lint checking"+                lintCurrentDirectory curdir "After completion"+                checkValid diagnostic database (runLint ruleinfo) =<< readIORef absent+                putWhen Loud "Lint checking succeeded"+            when (shakeReport /= []) $ do+                addTiming "Profile report"+                forM_ shakeReport $ \file -> do+                    putWhen Normal $ "Writing report to " ++ file+                    writeProfile file database+            when (shakeLiveFiles /= []) $ do+                addTiming "Listing live"+                diagnostic $ return "Listing live keys"+                xs <- liveFiles database+                forM_ shakeLiveFiles $ \file -> do+                    putWhen Normal $ "Writing live list to " ++ file+                    (if file == "-" then putStr else writeFile file) $ unlines xs++            res <- readIORef after+            addTiming "Cleanup"+            return res++        whenJustM (readIORef timingsToShow) $+            putStr . unlines+        return res++ -- | Run a set of IO actions, treated as \"after\" actions, typically returned from --   'Development.Shake.Database.shakeRunDatabase'. The actions will be run with diagnostics --   etc as specified in the 'ShakeOptions'.@@ -201,17 +225,11 @@  usingProgress :: Cleanup -> ShakeOptions -> Database -> Step -> IO (Maybe String) -> IO (IO Progress) usingProgress cleanup ShakeOptions{..} database step getFailure = do-    wait <- newBarrier     let getProgress = do             failure <- getFailure             stats <- progress database step             return stats{isFailure=failure}-    allocate cleanup-        (flip forkFinally (const $ signalBarrier wait ()) $-            shakeProgress getProgress)-        (\tid -> do-            killThread tid-            void $ timeout 1 $ waitBarrier wait)+    allocateThread cleanup $ shakeProgress getProgress     return getProgress  checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} {-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-}  module Development.Shake.Internal.Core.Types(@@ -23,6 +23,7 @@ import General.Binary import Control.Exception import Data.Maybe+import Data.List.Extra import General.Extra import Control.Concurrent.Extra import Development.Shake.Internal.History.Shared@@ -139,9 +140,13 @@ data Stack = Stack (Maybe Key) [Either Key [String]] !(Set.HashSet Id) deriving Show  exceptionStack :: Stack -> SomeException -> ShakeException-exceptionStack stack@(Stack _ xs _) = ShakeException (showTopStack stack) $-    concatMap f (reverse xs) ++ ["* Raised the exception:" | not $ null xs]+exceptionStack stack@(Stack _ xs1 _) (callStackFromException -> (xs2, e)) =+    ShakeException+        (showTopStack stack)+        (xs ++ ["* Raised the exception:" | not $ null xs])+        e     where+        xs = concatMap f $ reverse xs1 ++ [Right xs2]         f (Left x) = ["* Depends on: " ++ show x]         f (Right x) = map ("  at " ++) x @@ -322,9 +327,9 @@ --   as values will be compared for literal equality. --   The result of the identity should be reasonably short (if it is excessively long, hash it). -----   For rules where the value is never compatible use 'Development.Shake.Rules.noIdentity' and---   make sure to call 'Development.Shake.historyDisable' if you are ever depended upon.-type BuiltinIdentity key value = key -> value -> BS.ByteString+--   For rules where the value is never compatible use 'Development.Shake.Rules.noIdentity', which+--   returns 'Nothing'. This will disable shared caches of anything that depends on it.+type BuiltinIdentity key value = key -> value -> Maybe BS.ByteString  data BuiltinRule = BuiltinRule     {builtinLint :: BuiltinLint Key Value@@ -398,7 +403,7 @@     ,globalOutput :: Verbosity -> String -> IO () -- ^ Output function     ,globalOptions  :: ShakeOptions -- ^ Shake options     ,globalDiagnostic :: IO String -> IO () -- ^ Debugging function-    ,globalCurDir :: FilePath -- ^ getCurrentDirectory when we started+    ,globalRuleFinished :: Key -> Action () -- ^ actions to run after each rule     ,globalAfter :: IORef [IO ()] -- ^ Operations to run on success, e.g. removeFilesAfter     ,globalTrackAbsent :: IORef [(Key, Key)] -- ^ Tracked things, in rule fst, snd must be absent     ,globalProgress :: IO Progress -- ^ Request current progress state

@@ -107,7 +107,7 @@ errorComplexRecursion :: [String] -> SomeException errorComplexRecursion ks = errorStructured     "Build system error - indirect recursion detected"-    [("Key value " ++ show i, Just k) | (i, k) <- zip [1..] ks]+    [("Key value " ++ show i, Just k) | (i, k) <- zipFrom 1 ks]     "Rules may not be recursive"  errorNoApply :: TypeRep -> Maybe String -> String -> SomeException

@@ -29,7 +29,6 @@ import Development.Shake.Internal.Errors import Control.Monad import qualified Data.ByteString.Char8 as BS-import Foreign.C.Types import Foreign.C.String  #else@@ -137,8 +136,8 @@ #define CALLCONV stdcall #endif -foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: Ptr CChar  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool-foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: Ptr CWchar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: CString  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: CWString -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool  data WIN32_FILE_ATTRIBUTE_DATA 

@@ -1,18 +1,21 @@ {-# LANGUAGE RecordWildCards, TupleSections #-}  module Development.Shake.Internal.History.Shared(-    Shared, newShared, addShared, lookupShared+    Shared, newShared,+    addShared, lookupShared,+    removeShared, listShared     ) where  import Development.Shake.Internal.Value import Development.Shake.Internal.History.Types+import Development.Shake.Internal.History.Symlink import Development.Shake.Classes import General.Binary import General.Extra import General.Chunks import Control.Monad.Extra+import System.Directory.Extra import System.FilePath-import System.Directory import System.IO import Numeric import Development.Shake.Internal.FileInfo@@ -25,31 +28,7 @@ import qualified Data.ByteString as BS import Prelude -{--#ifndef mingw32_HOST_OS-import System.Posix.Files(createLink)-#else -import Foreign.Ptr-import Foreign.C.Types-import Foreign.C.String--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "Windows.h CreateHardLinkW" c_CreateHardLinkW :: Ptr CWchar -> Ptr CWchar -> Ptr () -> IO Bool--createLink :: FilePath -> FilePath -> IO ()-createLink from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do-    res <- c_CreateHardLinkW cfrom cto nullPtr-    unless res $ error $ show ("Failed to createLink", from, to)--#endif--}- data Shared = Shared     {globalVersion :: !Ver     ,keyOp :: BinaryOp Key@@ -126,9 +105,8 @@         -- use Nothing to indicate success, Just () to bail out early on mismatch         let result x = if isJust x then Nothing else Just $ (entryResult, map (map fst) entryDepends, ) $ do                 let dir = sharedFileDir shared entryKey-                forM_ entryFiles $ \(file, hash) -> do-                    createDirectoryRecursive $ takeDirectory file-                    copyFile (dir </> show hash) file+                forM_ entryFiles $ \(file, hash) ->+                    copyFileLink (dir </> show hash) file         result <$> firstJustM id             [ firstJustWaitUnordered id                 [ test <$> ask k | (k, i1) <- kis@@ -142,12 +120,37 @@     createDirectoryRecursive dir     withFile (dir </> "_key") AppendMode $ \h -> writeChunkDirect h $ putEntry (keyOp shared) entry     forM_ (entryFiles entry) $ \(file, hash) ->-        -- FIXME: should use a combination of symlinks and making files read-only         unlessM (doesFileExist_ $ dir </> show hash) $-            copyFile file (dir </> show hash)+            copyFileLink file (dir </> show hash)   addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO () addShared shared entryKey entryBuiltinVersion entryUserVersion entryDepends entryResult files = do-    hashes <- mapM (getFileHash . fileNameFromString) files-    saveSharedEntry shared Entry{entryFiles = zip files hashes, entryGlobalVersion = globalVersion shared, ..}+    files <- mapM (\x -> (x,) <$> getFileHash (fileNameFromString x)) files+    saveSharedEntry shared Entry{entryFiles = files, entryGlobalVersion = globalVersion shared, ..}+++removeShared :: Shared -> (Key -> Bool) -> IO ()+removeShared Shared{..} test = do+    dirs <- listDirectories $ sharedRoot </> ".shake.cache"+    deleted <- forM dirs $ \dir -> do+        (items, _slop) <- withFile (dir </> "_key") ReadMode $ \h ->+            readChunksDirect h maxBound+        -- if any key matches, clean them all out+        let b = any (test . entryKey . getEntry keyOp) items+        when b $ removeDirectoryRecursive dir+        return b+    liftIO $ putStrLn $ "Deleted " ++ show (length (filter id deleted)) ++ " entries"++listShared :: Shared -> IO ()+listShared Shared{..} = do+    dirs <- listDirectories $ sharedRoot </> ".shake.cache"+    forM_ dirs $ \dir -> do+        putStrLn $ "Directory: " ++ dir+        (items, _slop) <- withFile (dir </> "_key") ReadMode $ \h ->+            readChunksDirect h maxBound+        forM_ items $ \item -> do+            let Entry{..} = getEntry keyOp item+            putStrLn $ "  Key: " ++ show entryKey+            forM_ entryFiles $ \(file,_) ->+                putStrLn $ "    File: " ++ file

@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}++module Development.Shake.Internal.History.Symlink(+    copyFileLink+    ) where++import Control.Monad.Extra+import General.Extra+import System.Directory+import System.FilePath+++#ifdef mingw32_HOST_OS+import Foreign.Ptr+import Foreign.C.String+#else+import System.Posix.Files(createLink)+#endif++createLinkBool :: FilePath -> FilePath -> IO (Maybe String)++#ifdef mingw32_HOST_OS++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h CreateHardLinkW " c_CreateHardLinkW :: CWString -> CWString -> Ptr () -> IO Bool++createLinkBool from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do+    res <- c_CreateHardLinkW cto cfrom nullPtr+    return $ if res then Nothing else Just "CreateHardLink failed."++#else++createLinkBool from to = handleIO (return . Just . show) $ createLink from to >> return Nothing++#endif+++copyFileLink :: FilePath -> FilePath -> IO ()+copyFileLink from to = do+    createDirectoryRecursive $ takeDirectory to+    removeFile_ to+    b <- createLinkBool from to+    whenJust b $ \_ ->+        copyFile from to+    -- making files read only stops them from easily deleting+    when False $+        forM_ [from, to] $ \x -> do+            perm <- getPermissions x+            setPermissions x perm{writable=False}

@@ -14,6 +14,7 @@ import Data.Maybe import Data.Dynamic import Control.Monad+import General.Extra import qualified Data.HashMap.Strict as Map import Development.Shake.Internal.FilePattern import qualified Data.ByteString.Char8 as BS@@ -164,6 +165,8 @@         -- ^ Directories in which the files will be tracked by the linter.     ,shakeLintIgnore :: [FilePattern]         -- ^ File patterns which are ignored from linter tracking, a bit like calling 'Development.Shake.trackAllow' in every rule.+    ,shakeLintWatch :: [FilePattern]+        -- ^ File patterns whose modification causes an error. Raises an error even if 'shakeLint' is 'Nothing'.     ,shakeCommandOptions :: [CmdOption]         -- ^ Defaults to @[]@. Additional options to be passed to all command invocations.     ,shakeFlush :: Maybe Double@@ -213,6 +216,9 @@         -- ^ Defaults to writing using 'putStrLn'. A function called to output messages from Shake, along with the 'Verbosity' at         --   which that message should be printed. This function will be called atomically from all other 'shakeOutput' functions.         --   The 'Verbosity' will always be greater than or higher than 'shakeVerbosity'.+    ,shakeTrace :: String -> String -> Bool -> IO ()+        -- ^ Defaults to doing nothing.+        --   Called for each call of 'Development.Shake.traced', with the key, the command and 'True' for starting, 'False' for stopping.     ,shakeExtra :: Map.HashMap TypeRep Dynamic         -- ^ This a map which can be used to store arbitrary extra information that a user may need when writing rules.         --   The key of each entry must be the 'dynTypeRep' of the value.@@ -224,36 +230,39 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions shakeOptions = ShakeOptions-    ".shake" 1 "1" Normal False [] Nothing [] [] [] (Just 10) [] [] False True False+    ".shake" 1 "1" Normal False [] Nothing [] [] [] [] (Just 10) [] [] False True False     True ChangeModtime True [] False False Nothing []     (const $ return ())     (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS+    (\_ _ _ -> return ())     Map.empty  fieldsShakeOptions =     ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"-    ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeCommandOptions"+    ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeLintWatch", "shakeCommandOptions"     ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog"     ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"-    ,"shakeLiveFiles", "shakeVersionIgnore", "shakeProgress", "shakeShare", "shakeCloud", "shakeOutput", "shakeColor", "shakeExtra"]+    ,"shakeLiveFiles", "shakeVersionIgnore", "shakeColor", "shakeShare", "shakeCloud"+    ,"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 y1 y2 y3 =-    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 (fromHidden y1) (fromHidden y2) (fromHidden y3)+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 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+        (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 y1 y2 y3) =+    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 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`-        Hidden y1 `k` Hidden y2 `k` Hidden y3-    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 $ z unhide+        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`+        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 $ z unhide     toConstr ShakeOptions{} = conShakeOptions     dataTypeOf _ = tyShakeOptions  instance Show ShakeOptions where     show x = "ShakeOptions {" ++ intercalate ", " inner ++ "}"         where-            inner = zipWith (\x y -> x ++ " = " ++ y) fieldsShakeOptions $ gmapQ f x+            inner = zipWithExact (\x y -> x ++ " = " ++ y) fieldsShakeOptions $ gmapQ f x              f x | Just x <- cast x = show (x :: Int)                 | Just x <- cast x = show (x :: FilePath)@@ -269,6 +278,7 @@                 | Just x <- cast x = show (x :: Hidden (IO Progress -> IO ()))                 | Just x <- cast x = show (x :: Hidden (Verbosity -> String -> IO ()))                 | Just x <- cast x = show (x :: Hidden (Map.HashMap TypeRep Dynamic))+                | Just x <- cast x = show (x :: Hidden (String -> String -> Bool -> IO ()))                 | Just x <- cast x = show (x :: [CmdOption])                 | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x) 

@@ -10,8 +10,7 @@ import Control.Applicative import Data.Tuple.Extra import Control.Exception.Extra-import Control.Monad-import System.Environment.Extra+import Control.Monad.Extra import System.Directory import System.Process import System.FilePath@@ -25,7 +24,8 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Numeric.Extra import General.Template-import System.IO.Unsafe+import General.EscCodes+import General.Extra import Development.Shake.Internal.Paths import Data.Monoid import System.Time.Extra@@ -35,8 +35,7 @@  #ifdef mingw32_HOST_OS -import Foreign.Ptr-import Foreign.C.Types+import Foreign.C.String  #ifdef x86_64_HOST_ARCH #define CALLCONV ccall@@ -44,7 +43,7 @@ #define CALLCONV stdcall #endif -foreign import CALLCONV "Windows.h SetConsoleTitleA" c_setConsoleTitle :: Ptr CChar -> IO Bool+foreign import CALLCONV "Windows.h SetConsoleTitleW" c_setConsoleTitleW :: CWString -> IO Bool  #endif @@ -211,7 +210,9 @@ progressDisplay sample disp prog = do     disp "Starting..." -- no useful info at this stage     time <- offsetTime-    catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop time $ message echoMealy) (const $ disp "Finished")+    catchJust (\x -> if x == ThreadKilled then Just () else Nothing)+        (loop time $ message echoMealy)+        (const $ do t <- time; disp $ "Finished in " ++ showDuration t)     where         loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()         loop time mealy = do@@ -220,7 +221,12 @@             t <- time             ((secs,perc,_debug), mealy) <- return $ runMealy mealy (t, p)             -- putStrLn _debug-            disp $ formatMessage secs perc ++ maybe "" (", Failure! " ++) (isFailure p)+            let done = countSkipped p + countBuilt p+            let todo = done + countUnknown p + countTodo p+            disp $+                "Running for " ++ showDurationSecs t ++ " [" ++ show done ++ "/" ++ show todo ++ "]" +++                ", predicted " ++ formatMessage secs perc +++                maybe "" (", Failure! " ++) (isFailure p)             loop time mealy  @@ -288,24 +294,19 @@ jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"  -{-# NOINLINE xterm #-}-xterm :: Bool-xterm = unsafePerformIO $-    -- Terminal.app uses "xterm-256color" as its env variable-    maybe False ("xterm" `isPrefixOf`) <$> lookupEnv "TERM"-- -- | Set the title of the current console window to the given text. If the --   environment variable @$TERM@ is set to @xterm@ this uses xterm escape sequences. --   On Windows, if not detected as an xterm, this function uses the @SetConsoleTitle@ API. progressTitlebar :: String -> IO ()-progressTitlebar x-    | xterm = BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"+progressTitlebar x = unlessM win lin+    where #ifdef mingw32_HOST_OS-    | otherwise = BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()+        win = withCWString x c_setConsoleTitleW #else-    | otherwise = return ()+        win = return False #endif++        lin = whenM checkEscCodes $ BS.putStr $ BS.pack $ escWindowTitle x   -- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with

@@ -123,7 +123,7 @@     (\k old -> do         new <- query k         return $ if old == new then Nothing else Just $ show new)-    (\_ v -> runBuilder $ putEx $ witness v)+    (\_ v -> Just $ runBuilder $ putEx $ witness v)     (\k old _ -> liftIO $ do         new <- query k         let wnew = witness new

@@ -61,7 +61,7 @@  -- | Result of a File rule, may contain raw file information and whether the rule did run this build data FileR = FileR { answer :: !(Maybe FileA) -- ^ Raw information about the file built by this rule.-                                           --   Set to 'Nothing' to prevent linting some times.+                                              --   Set to 'Nothing' for 'phony' files.                    , useLint :: !Bool       -- ^ Should we lint the resulting file                    }     deriving (Typeable)@@ -203,8 +203,8 @@ ruleIdentity :: ShakeOptions -> BuiltinIdentity FileQ FileR ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure errorNoHash ruleIdentity _ = \k v -> case answer v of-    Just (FileA _ size hash) -> runBuilder $ putExStorable size <> putExStorable hash-    Nothing -> throwImpure $ errorInternal $ "File.ruleIdentity has no result for " ++ show k+    Just (FileA _ size hash) -> Just $ runBuilder $ putExStorable size <> putExStorable hash+    Nothing -> Nothing  ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Answer) mode = do@@ -291,7 +291,8 @@                     new <- act                     case new of                         Nothing -> do-                            alwaysRerun+                            -- Not 100% sure how you get here, but I think it involves RebuildLater and multi-file rules+                            historyDisable                             retNew ChangedRecomputeDiff AnswerPhony                         Just new -> answer (AnswerForward $ Ver ver) new                 Just (ver, ModeDirect act) -> do@@ -304,7 +305,12 @@                             act                             new <- liftIO $ storedValueError opts False "Error, rule finished running but did not produce file:" o                             case new of-                                Nothing -> retNew ChangedRecomputeDiff AnswerPhony+                                Nothing -> do+                                    -- rule ran, but didn't compute an answer, because shakeCreationCheck=False+                                    -- I think it should probably not return phony, but return a different valid-but-no-file+                                    -- but it's just too rare to bother+                                    historyDisable+                                    retNew ChangedRecomputeDiff AnswerPhony                                 Just new@(FileA _ _ fileHash) -> do                                     producesUnchecked [xStr]                                     res <- answer (AnswerDirect $ Ver ver) new@@ -500,10 +506,11 @@ --   similar effect.  However, while in make it is acceptable to omit --   the @.PHONY@ attribute as long as you don't create the file in --   question, a Shake rule which behaves this way will fail lint.---   Use a phony rule!  For file-producing rules which should be+--   For file-producing rules which should be --   rerun every execution of Shake, see 'Development.Shake.alwaysRerun'. phony :: Located => String -> Action () -> Rules ()-phony oname@(toStandard -> name) act =+phony oname@(toStandard -> name) act = do+    addTarget oname     addPhony ("phony " ++ show oname ++ " at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing  -- | A predicate version of 'phony', return 'Just' with the 'Action' for the matching rules.@@ -513,7 +520,8 @@ -- | Infix operator alias for 'phony', for sake of consistency with normal --   rules. (~>) :: Located => String -> Action () -> Rules ()-(~>) oname@(toStandard -> name) act =+(~>) oname@(toStandard -> name) act = do+    addTarget oname     addPhony (show oname ++ " ~> at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing  addPhony :: String -> (String -> Maybe (Action ())) -> Rules ()@@ -541,6 +549,7 @@ --   Think of it as the OR (@||@) equivalent of '%>'. (|%>) :: Located => [FilePattern] -> (FilePath -> Action ()) -> Rules () (|%>) pats act = do+    mapM_ addTarget pats     let (simp,other) = partition simple pats     case map toStandard simp of         [] -> return ()@@ -572,4 +581,7 @@ --   If the 'Action' completes successfully the file is considered up-to-date, even if the file --   has not changed. (%>) :: Located => FilePattern -> (FilePath -> Action ()) -> Rules ()-(%>) test act = withFrozenCallStack $ (if simple test then id else priority 0.5) $ root (show test ++ " %> at " ++ callStackTop) (test ?==) act+(%>) test act = withFrozenCallStack $+    (if simple test then id else priority 0.5) $ do+        addTarget test+        root (show test ++ " %> at " ++ callStackTop) (test ?==) act

@@ -62,7 +62,7 @@ filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost filesEqualValue opts (FilesA xs) (FilesA ys)     | length xs /= length ys = NotEqual-    | otherwise = foldr and_ EqualCheap $ zipWith (fileEqualValue opts) xs ys+    | otherwise = foldr and_ EqualCheap $ zipWithExact (fileEqualValue opts) xs ys         where and_ NotEqual _ = NotEqual               and_ EqualCheap x = x               and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive@@ -86,7 +86,7 @@ ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure $ errorStructured     "Cannot use shakeChange=ChangeModTime with shakeShare" [] "" ruleIdentity _ = \_ (FilesA files) ->-    runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]+    Just $ runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]   @@ -129,7 +129,7 @@             cache <- historyLoad ver             v <- case cache of                 Just res ->-                    fmap FilesA $ forM (zip (getExList res) (fromFilesQ k)) $ \(bin, file) -> do+                    fmap FilesA $ forM (zipExact (getExList res) (fromFilesQ k)) $ \(bin, file) -> do                         Just (FileA mod size _) <- liftIO $ fileStoredValue opts file                         return $ FileA mod size $ getExStorable bin                 Nothing -> do@@ -163,7 +163,7 @@ [p] &%> act = withFrozenCallStack $ p %> act . return ps &%> act     | not $ compatible ps = error $ unlines $-        "All patterns to &%> must have the same number and position of // and * wildcards" :+        "All patterns to &%> must have the same number and position of ** and * wildcards" :         ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]     | otherwise = withFrozenCallStack $ do         forM_ (zipFrom 0 ps) $ \(i,p) ->@@ -171,9 +171,10 @@                 fileForward (show ps ++ " &%> at " ++ callStackTop) $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do                     FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString . substitute (extract p file)) ps                     return $ if null res then Nothing else Just $ res !! i-        (if all simple ps then id else priority 0.5) $+        (if all simple ps then id else priority 0.5) $ do+            mapM_ addTarget ps             addUserRule $ FilesRule (show ps ++ " &%> " ++ callStackTop) $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in-                if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do+                if not $ length xs == length ps && and (zipWithExact (?==) ps xs) then Nothing else Just $ do                     liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs                     trackAllow xs                     act xs@@ -244,4 +245,4 @@             let missing = length $ filter isNothing ys             error $ "Error, " ++ name ++ " rule failed to produce " ++ show missing ++                     " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++-                    concat ["\n  " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]+                    concat ["\n  " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zipExact xs ys]

@@ -37,7 +37,7 @@         opts <- getShakeOptionsRules         let skip = shakeRebuildApply opts "" == RebuildLater -        addBuiltinRule noLint (\_ v -> runBuilder $ putEx $ hash v) $ \(OracleQ q) old mode -> case old of+        addBuiltinRule noLint (\_ v -> Just $ runBuilder $ putEx $ hash v) $ \(OracleQ q) old mode -> case old of             Just old | (flavor /= Hash && skip) || (flavor == Cache && mode == RunDependenciesSame) ->                 return $ RunResult ChangedNothing old $ decode' old             _ -> do

@@ -76,7 +76,7 @@ -- | A version of 'shakeArgsPrune' that also takes a list of extra options to use. shakeArgsPruneWith :: ShakeOptions -> ([FilePath] -> IO ()) -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO () shakeArgsPruneWith opts prune flags act = do-    let flags2 = Option "P" ["prune"] (NoArg $ Right Nothing) "Remove stale files" : map (fmapOptDescr Just) flags+    let flags2 = Option "P" ["prune"] (NoArg $ Right Nothing) "Remove stale files" : map (fmapFmapOptDescr Just) flags     pruning <- newIORef False     shakeArgsWith opts flags2 $ \opts args ->         case sequence opts of

@@ -20,6 +20,7 @@ import General.Binary import General.Extra import General.Cleanup+import General.Thread import Prelude  @@ -77,20 +78,18 @@     died <- newBarrier -- has the writing thread finished      whenJust chunksFlush $ \flush ->-        void $ allocate cleanup-            (forkIO $ forever $ do-                takeMVar kick-                sleep flush-                tryTakeMVar kick-                writeChan chan $ hFlush h >> return True)-            killThread+        allocateThread cleanup $ forever $ do+            takeMVar kick+            sleep flush+            tryTakeMVar kick+            writeChan chan $ hFlush h >> return True -    root <- myThreadId-    allocate cleanup-        (flip forkFinally (\e -> do signalBarrier died (); whenLeft e (throwTo root)) $-            -- only one thread ever writes, ensuring only the final write can be torn-            whileM $ join $ readChan chan)-        (const $ do writeChan chan $ return False; waitBarrier died)+    -- pump the thread while we are running+    -- once we abort, let everything finish flushing first+    -- the mask_ is very important - we don't want to abort until everything finishes+    allocateThread cleanup $ mask_ $ whileM $ join $ readChan chan+    -- this cleanup will run before we attempt to kill the thread+    register cleanup $ writeChan chan $ return False      return $ \s -> do         out <- evaluate $ writeChunkDirect h s -- ensure exceptions occur on this thread

@@ -22,8 +22,9 @@ data ReleaseKey = ReleaseKey (IORef S) {-# UNPACK #-} !Int  --- | Run with some cleanup scope. Regardless of exceptions/threads, all 'addCleanup' actions---   will be run by the time it exits. The 'addCleanup' actions will be run in reverse order.+-- | Run with some cleanup scope. Regardless of exceptions/threads, all 'register' actions+--   will be run by the time it exits.+--   The 'register' actions will be run in reverse order, i.e. the last to be added will be run first. withCleanup :: (Cleanup -> IO a) -> IO a withCleanup act = do     (c, clean) <- newCleanup

@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}++-- | Working with escape sequences+module General.EscCodes(+    Color(..),+    checkEscCodes,+    removeEscCodes,+    escWindowTitle,+    escCursorUp,+    escClearLine,+    escForeground,+    escNormal+    ) where++import Data.Char+import System.IO+import System.Environment.Extra+import System.IO.Unsafe+import Data.Functor+import Prelude++#ifdef mingw32_HOST_OS+import Data.Word+import Data.Bits+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+#endif++checkEscCodes :: IO Bool+checkEscCodes = return checkEscCodesOnce++{-# NOINLINE checkEscCodesOnce #-}+checkEscCodesOnce :: Bool+checkEscCodesOnce = unsafePerformIO $ do+    hdl <- hIsTerminalDevice stdout+    env <- maybe False (/= "dumb") <$> lookupEnv "TERM"+    if hdl && env then return True else+#ifdef mingw32_HOST_OS+        checkEscCodesWindows+#else+        return False+#endif++#ifdef mingw32_HOST_OS++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h GetStdHandle" c_GetStdHandle :: Word32 -> IO (Ptr ())+foreign import CALLCONV unsafe "Windows.h GetConsoleMode" c_GetConsoleModule :: Ptr () -> Ptr Word32 -> IO Bool+foreign import CALLCONV unsafe "Windows.h SetConsoleMode" c_SetConsoleMode :: Ptr () -> Word32 -> IO Bool++c_STD_OUTPUT_HANDLE = 4294967285 :: Word32 -- (-11) for some reason+c_ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 :: Word32+++-- | Try and get the handle attributes, if they are all satisifed, return True.+--   If they aren't, try and set it to emulated mode.+checkEscCodesWindows :: IO Bool+checkEscCodesWindows = do+    h <- c_GetStdHandle c_STD_OUTPUT_HANDLE+    -- might return INVALID_HANDLE_VALUE, but then the next step will happily fail+    mode <- alloca $ \v -> do+        b <- c_GetConsoleModule h v+        if b then Just <$> peek v else return Nothing+    case mode of+        Nothing -> return False+        Just mode -> do+            let modeNew = mode .|. c_ENABLE_VIRTUAL_TERMINAL_PROCESSING+            if mode == modeNew then return True else do+                c_SetConsoleMode h modeNew+#endif++removeEscCodes :: String -> String+removeEscCodes ('\ESC':'[':xs) = removeEscCodes $ drop 1 $ dropWhile (not . isAlpha) xs+removeEscCodes (x:xs) = x : removeEscCodes xs+removeEscCodes [] = []+++escWindowTitle :: String -> String+escWindowTitle x = "\ESC]0;" ++ x ++ "\BEL"++escCursorUp :: Int -> String+escCursorUp i = "\ESC[" ++ show i ++ "A"++escClearLine :: String+escClearLine = "\ESC[K"+++data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White+    deriving (Show,Enum)++escForeground :: Color -> String+escForeground x = "\ESC[" ++ show (30 + fromEnum x) ++ "m"++escNormal :: String+escNormal = "\ESC[0m"

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RecordWildCards, GeneralizedNewtypeDeriving, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RecordWildCards, GeneralizedNewtypeDeriving, ViewPatterns, Rank2Types #-}  module General.Extra(     getProcessorCount,@@ -7,17 +7,18 @@     whenLeft,     randomElem,     wrapQuote, showBracket,-    withs,+    withs, forNothingM,     maximum', maximumBy',     fastAt,-    forkFinallyUnmasked,+    zipExact, zipWithExact,     isAsyncException,+    showDurationSecs,     usingLineBuffering,     doesFileExist_,     usingNumCapabilities,     removeFile_, createDirectoryRecursive,     catchIO, tryIO, handleIO,-    Located, Partial, callStackTop, callStackFull, withFrozenCallStack,+    Located, Partial, callStackTop, callStackFull, withFrozenCallStack, callStackFromException,     Ver(..), makeVer,     QTypeRep(..)     ) where@@ -32,11 +33,13 @@ import General.Cleanup import Data.Typeable import System.IO.Extra+import System.Time.Extra import System.IO.Unsafe import System.Info.Extra import System.Random import System.Directory import System.Exit+import Numeric.Extra import Foreign.Storable import Control.Concurrent.Extra import Data.Maybe@@ -95,7 +98,17 @@                 writeArray arr i x             unsafeFreezeArray arr +zipWithExact :: Partial => (a -> b -> c) -> [a] -> [b] -> [c]+zipWithExact f = g+    where+        g [] [] = []+        g (a:as) (b:bs) = f a b : g as bs+        g _ _ = error "zipWithExacts: unequal lengths" +zipExact :: Partial => [a] -> [b] -> [(a,b)]+zipExact = zipWithExact (,)++ --------------------------------------------------------------------- -- System.Info @@ -156,22 +169,31 @@   ---------------------------------------------------------------------+-- System.Time++showDurationSecs :: Seconds -> String+showDurationSecs = replace ".00s" "s" . showDuration . intToDouble . round+++--------------------------------------------------------------------- -- Control.Monad  withs :: [(a -> r) -> r] -> ([a] -> r) -> r withs [] act = act [] withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as +forNothingM :: Monad m => [a] -> (a -> m (Maybe b)) -> m (Maybe [b])+forNothingM [] f = return $ Just []+forNothingM (x:xs) f = do+    v <- f x+    case v of+        Nothing -> return Nothing+        Just v -> liftM (v:) `liftM` forNothingM xs f + --------------------------------------------------------------------- -- Control.Concurrent --- | Like 'forkFinally', but the inner thread is unmasked even if you started masked.-forkFinallyUnmasked :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkFinallyUnmasked act cleanup =-    mask_ $ forkIOWithUnmask $ \unmask ->-        try (unmask act) >>= cleanup- usingNumCapabilities :: Cleanup -> Int -> IO () usingNumCapabilities cleanup new = when rtsSupportsBoundThreads $ do     old <- getNumCapabilities@@ -234,21 +256,23 @@ callStackTop = withFrozenCallStack $ head $ callStackFull ++ ["unknown location"]  callStackFull :: Partial => [String]+callStackFromException :: SomeException -> ([String], SomeException) + #if __GLASGOW_HASKELL__ >= 800 -callStackFull = map f $ getCallStack $ popCallStack callStack-    where-        f (_, SrcLoc{..}) = toStandard srcLocFile ++ ":" ++-            -- match the format of GHC error messages-            if srcLocStartLine == srcLocEndLine then-                show srcLocStartLine ++ ":" ++ show srcLocStartCol ++-                (if srcLocStartCol == srcLocEndCol then "" else "-" ++ show srcLocEndCol) ++ ":"-            else-                show (srcLocStartLine, srcLocStartCol) ++ "-" ++ show (srcLocEndLine, srcLocEndCol) ++ ":"+-- | Invert 'prettyCallStack', which GHC pre-applies in certain cases+parseCallStack = reverse . map trimStart . drop 1 . lines++callStackFull = parseCallStack $ prettyCallStack $ popCallStack callStack++callStackFromException (fromException -> Just (ErrorCallWithLocation msg loc)) = (parseCallStack loc, toException $ ErrorCall msg)+callStackFromException e = ([], e)+ #else  callStackFull = []+callStackFromException e = ([], e)  withFrozenCallStack :: a -> a withFrozenCallStack = id

@@ -11,7 +11,6 @@ import Data.Bits import Data.Word import Foreign.Ptr-import Foreign.C.Types import Foreign.C.String #else import System.IO@@ -26,7 +25,7 @@ #define CALLCONV stdcall #endif -foreign import CALLCONV unsafe "Windows.h CreateFileW" c_CreateFileW :: Ptr CWchar -> Word32 -> Word32 -> Ptr () -> Word32 -> Word32 -> Ptr () -> IO (Ptr ())+foreign import CALLCONV unsafe "Windows.h CreateFileW" c_CreateFileW :: CWString -> Word32 -> Word32 -> Ptr () -> Word32 -> Word32 -> Ptr () -> IO (Ptr ()) foreign import CALLCONV unsafe "Windows.h CloseHandle" c_CloseHandle :: Ptr () -> IO Bool foreign import CALLCONV unsafe "Windows.h GetLastError" c_GetLastError :: IO Word32 

@@ -2,7 +2,7 @@ module General.GetOpt(     OptDescr(..), ArgDescr(..),     getOpt,-    fmapOptDescr,+    fmapFmapOptDescr,     showOptDescr,     mergeOptDescr,     removeOverlap,@@ -24,14 +24,19 @@           (flagBad, flagGood) = partitionEithers flags  +fmapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b+fmapArgDescr f (NoArg a) = NoArg $ f a+fmapArgDescr f (ReqArg a b) = ReqArg (f . a) b+fmapArgDescr f (OptArg a b) = OptArg (f . a) b+ -- fmap is only an instance in later GHC 7.8 and above, so fake our own version-fmapOptDescr :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)-fmapOptDescr f (Option a b c d) = Option a b (g c) d-    where g (NoArg a) = NoArg $ fmap f a-          g (ReqArg a b) = ReqArg (fmap f . a) b-          g (OptArg a b) = OptArg (fmap f . a) b+fmapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b+fmapOptDescr f (Option a b c d) = Option a b (fmapArgDescr f c) d +fmapFmapOptDescr :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)+fmapFmapOptDescr f = fmapOptDescr (fmap f) + showOptDescr :: [OptDescr a] -> [String] showOptDescr xs = concat     [ if nargs <= 26 then ["  " ++ args ++ replicate (28 - nargs) ' ' ++ desc]@@ -59,7 +64,7 @@                   b2 = filter (not . flip Set.member long) b  mergeOptDescr :: [OptDescr (Either String a)] -> [OptDescr (Either String b)] -> [OptDescr (Either String (Either a b))]-mergeOptDescr xs ys = map (fmapOptDescr Left) xs ++ map (fmapOptDescr Right) ys+mergeOptDescr xs ys = map (fmapFmapOptDescr Left) xs ++ map (fmapFmapOptDescr Right) ys  optionsEnum :: (Enum a, Bounded a, Show a) => [OptDescr (Either String a)] optionsEnum = optionsEnumDesc [(x, "Flag " ++ lower (show x) ++ ".") | x <- [minBound..maxBound]]

@@ -1,246 +0,0 @@--- Copied from https://github.com/ekmett/heaps/blob/87c2c8098270d6cf76f1017182c1f7effa8357e6/src/Data/Heap.hs--- Because I can't depend on 'heaps', see https://github.com/ekmett/heaps/issues/13--- I removed the CPP---------------------------------------------------------------------------------- |--- Copyright   :  (c) Edward Kmett 2010-2015--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ An efficient, asymptotically optimal, implementation of a priority queues--- extended with support for efficient size, and `Data.Foldable`------ /Note/: Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ >  import Data.Heap (Heap)--- >  import qualified Data.Heap as Heap------ The implementation of 'Heap' is based on /bootstrapped skew binomial heaps/--- as described by:------    * G. Brodal and C. Okasaki , <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.48.973 "Optimal Purely Functional Priority Queues">,---      /Journal of Functional Programming/ 6:839-857 (1996)------ All time bounds are worst-case.--------------------------------------------------------------------------------module General.Heap-    (-    -- * Heap Type-      Heap -- instance Eq,Ord,Show,Read,Data,Typeable-    -- * Entry type-    , Entry(..) -- instance Eq,Ord,Show,Read,Data,Typeable-    -- * Basic functions-    , empty             -- O(1) :: Heap a-    , insert            -- O(1) :: Ord a => a -> Heap a -> Heap a-    , uncons            -- O(1)\/O(log n) :: Heap a -> Maybe (a, Heap a)-    ) where--import Data.Monoid-import Data.Foldable hiding (minimum, concatMap)-import Data.Function (on)-import Prelude hiding (foldr)---- The implementation of 'Heap' must internally hold onto the dictionary entry for ('<='),--- so that it can be made 'Foldable'. Confluence in the absence of incoherent instances--- is provided by the fact that we only ever build these from instances of 'Ord' a (except in the case of 'groupBy')----- | A min-heap of values of type @a@.-data Heap a-  = Empty-  | Heap {-# UNPACK #-} !Int (a -> a -> Bool) {-# UNPACK #-} !(Tree a)--instance Show a => Show (Heap a) where-  showsPrec _ Empty = showString "fromList []"-  showsPrec d (Heap _ _ t) = showParen (d > 10) $-    showString "fromList " .  showsPrec 11 (toList t)---- | /O(1)/. The empty heap------ @'empty' ≡ 'fromList' []@------ >>> size empty--- 0-empty :: Heap a-empty = Empty-{-# INLINE empty #-}---singletonWith :: (a -> a -> Bool) -> a -> Heap a-singletonWith f a = Heap 1 f (Node 0 a Nil)-{-# INLINE singletonWith #-}---- | /O(1)/. Insert a new value into the heap.------ >>> insert 2 (fromList [1,3])--- fromList [1,2,3]------ @--- 'insert' x 'empty' ≡ 'singleton' x--- 'size' ('insert' x xs) ≡ 1 + 'size' xs--- @-insert :: Ord a => a -> Heap a -> Heap a-insert = insertWith (<=)-{-# INLINE insert #-}--insertWith :: (a -> a -> Bool) -> a -> Heap a -> Heap a-insertWith leq x Empty = singletonWith leq x-insertWith leq x (Heap s _ t@(Node _ y f))-  | leq x y   = Heap (s+1) leq (Node 0 x (t `Cons` Nil))-  | otherwise = Heap (s+1) leq (Node 0 y (skewInsert leq (Node 0 x Nil) f))-{-# INLINE insertWith #-}----- | Provides both /O(1)/ access to the minimum element and /O(log n)/ access to the remainder of the heap.--- This is the same operation as 'viewMin'------ >>> uncons (fromList [2,1,3])--- Just (1,fromList [2,3])-uncons :: Heap a -> Maybe (a, Heap a)-uncons Empty = Nothing-uncons l@(Heap _ _ t) = Just (root t, deleteMin l)-{-# INLINE uncons #-}---trees :: Forest a -> [Tree a]-trees (a `Cons` as) = a : trees as-trees Nil = []---- | /O(log n)/. Delete the minimum key from the heap and return the resulting heap.------ >>> deleteMin (fromList [3,1,2])--- fromList [2,3]-deleteMin :: Heap a -> Heap a-deleteMin Empty = Empty-deleteMin (Heap _ _ (Node _ _ Nil)) = Empty-deleteMin (Heap s leq (Node _ _ f0)) = Heap (s - 1) leq (Node 0 x f3)-  where-    (Node r x cf, ts2) = getMin leq f0-    (zs, ts1, f1) = splitForest r Nil Nil cf-    f2 = skewMeld leq (skewMeld leq ts1 ts2) f1-    f3 = foldr (skewInsert leq) f2 (trees zs)-{-# INLINE deleteMin #-}---- * Subranges---- we hold onto the children counts in the nodes for /O(1)/ 'size'-data Tree a = Node-  { rank :: {-# UNPACK #-} !Int-  , root :: a-  , _forest :: !(Forest a)-  } deriving (Show)--data Forest a = !(Tree a) `Cons` !(Forest a) | Nil-  deriving (Show)-infixr 5 `Cons`--instance Functor Tree where-  fmap f (Node r a as) = Node r (f a) (fmap f as)--instance Functor Forest where-  fmap f (a `Cons` as) = fmap f a `Cons` fmap f as-  fmap _ Nil = Nil---- internal foldable instances that should only be used over commutative monoids-instance Foldable Tree where-  foldMap f (Node _ a as) = f a `mappend` foldMap f as---- internal foldable instances that should only be used over commutative monoids-instance Foldable Forest where-  foldMap f (a `Cons` as) = foldMap f a `mappend` foldMap f as-  foldMap _ Nil = mempty--link :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a-link f t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2) -- assumes r1 == r2-  | f x1 x2   = Node (r1+1) x1 (t2 `Cons` cf1)-  | otherwise = Node (r2+1) x2 (t1 `Cons` cf2)--skewLink :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a -> Tree a-skewLink f t0@(Node _ x0 cf0) t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2)-  | f x1 x0 && f x1 x2 = Node (r1+1) x1 (t0 `Cons` t2 `Cons` cf1)-  | f x2 x0 && f x2 x1 = Node (r2+1) x2 (t0 `Cons` t1 `Cons` cf2)-  | otherwise          = Node (r1+1) x0 (t1 `Cons` t2 `Cons` cf0)--ins :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a-ins _ t Nil = t `Cons` Nil-ins f t (t' `Cons` ts) -- assumes rank t <= rank t'-  | rank t < rank t' = t `Cons` t' `Cons` ts-  | otherwise = ins f (link f t t') ts--uniqify :: (a -> a -> Bool) -> Forest a -> Forest a-uniqify _ Nil = Nil-uniqify f (t `Cons` ts) = ins f t ts--unionUniq :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a-unionUniq _ Nil ts = ts-unionUniq _ ts Nil = ts-unionUniq f tts1@(t1 `Cons` ts1) tts2@(t2 `Cons` ts2) = case compare (rank t1) (rank t2) of-  LT -> t1 `Cons` unionUniq f ts1 tts2-  EQ -> ins f (link f t1 t2) (unionUniq f ts1 ts2)-  GT -> t2 `Cons` unionUniq f tts1 ts2--skewInsert :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a-skewInsert f t ts@(t1 `Cons` t2 `Cons`rest)-  | rank t1 == rank t2 = skewLink f t t1 t2 `Cons` rest-  | otherwise = t `Cons` ts-skewInsert _ t ts = t `Cons` ts-{-# INLINE skewInsert #-}--skewMeld :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a-skewMeld f ts ts' = unionUniq f (uniqify f ts) (uniqify f ts')-{-# INLINE skewMeld #-}--getMin :: (a -> a -> Bool) -> Forest a -> (Tree a, Forest a)-getMin _ (t `Cons` Nil) = (t, Nil)-getMin f (t `Cons` ts)-  | f (root t) (root t') = (t, ts)-  | otherwise            = (t', t `Cons` ts')-  where (t',ts') = getMin f ts-getMin _ Nil = error "Heap.getMin: empty forest"--splitForest :: Int -> Forest a -> Forest a -> Forest a -> (Forest a, Forest a, Forest a)-splitForest a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined-splitForest 0 zs ts f = (zs, ts, f)-splitForest 1 zs ts (t `Cons` Nil) = (zs, t `Cons` ts, Nil)-splitForest 1 zs ts (t1 `Cons` t2 `Cons` f)-  -- rank t1 == 0-  | rank t2 == 0 = (t1 `Cons` zs, t2 `Cons` ts, f)-  | otherwise    = (zs, t1 `Cons` ts, t2 `Cons` f)-splitForest r zs ts (t1 `Cons` t2 `Cons` cf)-  -- r1 = r - 1 or r1 == 0-  | r1 == r2          = (zs, t1 `Cons` t2 `Cons` ts, cf)-  | r1 == 0           = splitForest (r-1) (t1 `Cons` zs) (t2 `Cons` ts) cf-  | otherwise         = splitForest (r-1) zs (t1 `Cons` ts) (t2 `Cons` cf)-  where-    r1 = rank t1-    r2 = rank t2-splitForest _ _ _ _ = error "Heap.splitForest: invalid arguments"----- | Explicit priority/payload tuples. Useful to build a priority queue using--- a 'Heap', since the payload is ignored in the Eq/Ord instances.------ @--- myHeap = 'fromList' ['Entry' 2 \"World", 'Entry' 1 \"Hello", 'Entry' 3 "!"]------ ==> 'foldMap' 'payload' myHeap ≡ "HelloWorld!"--- @-data Entry p a = Entry { priority :: p, payload :: a }-  deriving (Show)---- instance Comonad (Entry p) where---   extract (Entry _ a) = a---   extend f pa@(Entry p _) Entry p (f pa)--instance Eq p => Eq (Entry p a) where-  (==) = (==) `on` priority-  {-# INLINE (==) #-}--instance Ord p => Ord (Entry p a) where-  compare = compare `on` priority-  {-# INLINE compare #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-}  module General.ListBuilder(     ListBuilder, runListBuilder, newListBuilder@@ -5,12 +6,13 @@  import Data.Semigroup (Semigroup (..)) import Data.Monoid hiding ((<>))-import Prelude()+import Prelude(Functor)  data ListBuilder a     = Zero     | One a     | Add (ListBuilder a) (ListBuilder a)+      deriving Functor   instance Semigroup (ListBuilder a) where

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-}  -- | Thread pool implementation. The three names correspond to the following --   priority levels (highest to lowest):@@ -22,8 +23,8 @@ import Control.Exception import Control.Monad.Extra import General.Timing-import General.Extra-import qualified General.Heap as Heap+import General.Thread+import qualified Data.Heap as Heap import qualified Data.HashSet as Set import Data.IORef.Extra import System.Random@@ -37,12 +38,9 @@ If any worker throws an exception, must signal to all the other workers -} -data Pool = Pool-    !(Var (Maybe S)) -- Current state, 'Nothing' to say we are aborting-    !(Barrier (Either SomeException S)) -- Barrier to signal that we are finished- data S = S-    {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stacks+    {alive :: !Bool -- True until there's an exception, after which don't spawn more tasks+    ,threads :: !(Set.HashSet Thread) -- IMPORTANT: Must be strict or we leak thread stacks     ,threadsLimit :: {-# UNPACK #-} !Int -- user supplied thread limit, Set.size threads <= threadsLimit     ,threadsCount :: {-# UNPACK #-} !Int -- Set.size threads, but in O(1)     ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads (accounting only)@@ -58,41 +56,52 @@         ref <- newIORef 0         -- no need to be thread-safe - if two threads race they were basically the same time anyway         return $ do i <- readIORef ref; writeIORef' ref (i+1); return i-    return $ S Set.empty n 0 0 0 rand Heap.empty+    return $ S True Set.empty n 0 0 0 rand Heap.empty  +data Pool = Pool+    !(Var S) -- Current state, 'alive' = False to say we are aborting+    !(Barrier (Either SomeException S)) -- Barrier to signal that we are finished+++withPool :: Pool -> (S -> IO (S, IO ())) -> IO ()+withPool (Pool var _) f = join $ modifyVar var $ \s ->+    if alive s then f s else return (s, return ())++withPool_ :: Pool -> (S -> IO S) -> IO ()+withPool_ pool act = withPool pool $ fmap (, return()) . act++ worker :: Pool -> IO ()-worker pool@(Pool var _) = do-    let onVar act = modifyVar var $ maybe (return (Nothing, return ())) act-    join $ onVar $ \s ->return $ case Heap.uncons $ todo s of-        Nothing -> (Just s, return ())-        Just (Heap.Entry _ now, todo2) -> (Just s{todo = todo2}, now >> worker pool)+worker pool = withPool pool $ \s -> return $ case Heap.uncons $ todo s of+    Nothing -> (s, return ())+    Just (Heap.Entry _ now, todo2) -> (s{todo = todo2}, now >> worker pool) --- | Given a pool, and a function that breaks the S invariants, restore them---   They are only allowed to touch threadsLimit or todo+-- | Given a pool, and a function that breaks the S invariants, restore them.+--   They are only allowed to touch threadsLimit or todo.+--   Assumes only requires spawning a most one job (e.g. can't increase the pool by more than one at a time) step :: Pool -> (S -> IO S) -> IO ()-step pool@(Pool var done) op = do-    let onVar act = modifyVar_ var $ maybe (return Nothing) act-    onVar $ \s -> do-        s <- op s-        case Heap.uncons $ todo s of-            Just (Heap.Entry _ now, todo2) | threadsCount s < threadsLimit s -> do-                -- spawn a new worker-                t <- forkFinallyUnmasked (now >> worker pool) $ \res -> case res of-                    Left e -> onVar $ \s -> do-                        t <- myThreadId-                        mapM_ killThread $ Set.toList $ Set.delete t $ threads s-                        signalBarrier done $ Left e-                        return Nothing-                    Right _ -> do-                        t <- myThreadId-                        step pool $ \s -> return s{threads = Set.delete t $ threads s, threadsCount = threadsCount s - 1}-                return $ Just s{todo = todo2, threads = Set.insert t $ threads s, threadsCount = threadsCount s + 1-                               ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` (threadsCount s + 1)}-            Nothing | threadsCount s == 0 -> do-                signalBarrier done $ Right s-                return Nothing-            _ -> return $ Just s+-- mask_ is so we don't spawn and not record it+step pool@(Pool _ done) op = mask_ $ withPool_ pool $ \s -> do+    s <- op s+    case Heap.uncons $ todo s of+        Just (Heap.Entry _ now, todo2) | threadsCount s < threadsLimit s -> do+            -- spawn a new worker+            t <- newThreadFinally (now >> worker pool) $ \t res -> case res of+                Left e -> withPool_ pool $ \s -> do+                    signalBarrier done $ Left e+                    return (remThread t s){alive = False}+                Right _ ->+                    step pool $ return . remThread t+            return (addThread t s){todo = todo2}+        Nothing | threadsCount s == 0 -> do+            signalBarrier done $ Right s+            return s{alive = False}+        _ -> return s+    where+        addThread t s = s{threads = Set.insert t $ threads s, threadsCount = threadsCount s + 1+                         ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` (threadsCount s + 1)}+        remThread t s = s{threads = Set.delete t $ threads s, threadsCount = threadsCount s - 1}   -- | Add a new task to the pool. See the top of the module for the relative ordering@@ -133,19 +142,14 @@  -- | Run all the tasks in the pool on the given number of works. --   If any thread throws an exception, the exception will be reraised.---   When it completes all threads have either finished, or have had 'killThread'---   called on them (but may not have actually died yet). runPool :: Bool -> Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool runPool deterministic n act = do-    s <- newVar . Just =<< emptyS n deterministic+    s <- newVar =<< emptyS n deterministic     done <- newBarrier+    let pool = Pool s done -    let cleanup = modifyVar_ s $ \s -> do-            -- if someone kills our thread, make sure we kill our child threads-            case s of-                Just s -> mapM_ killThread $ Set.toList $ threads s-                Nothing -> return ()-            return Nothing+    -- if someone kills our thread, make sure we kill our child threads+    let cleanup = join $ modifyVar s $ \s -> return (s{alive=False}, stopThreads $ Set.toList $ threads s)      let ghc10793 = do             -- if this thread dies because it is blocked on an MVar there's a chance we have@@ -157,8 +161,7 @@             case res of                 Just (Left e) -> throwIO e                 _ -> throwIO BlockedIndefinitelyOnMVar-    handle (\BlockedIndefinitelyOnMVar -> ghc10793) $ flip onException cleanup $ do-        let pool = Pool s done+    flip finally cleanup $ handle (\BlockedIndefinitelyOnMVar -> ghc10793) $ do         addPool PoolStart pool $ act pool         res <- waitBarrier done         case res of

@@ -134,7 +134,7 @@  withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a withFiles mode files act = withs (map (`withFile` mode) files) $ \handles ->-    act $ \x -> fromJust $ lookup x $ zip files handles+    act $ \x -> fromJust $ lookup x $ zipExact files handles   -- General approach taken from readProcessWithExitCode

@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence+module General.Thread(+    withThreadsBoth,+    withThreadSlave,+    allocateThread,+    Thread, newThreadFinally, stopThreads+    ) where++import General.Cleanup+import Data.Hashable+import Control.Concurrent.Extra+import Control.Exception+import General.Extra+import Control.Monad.Extra+++data Thread = Thread ThreadId (Barrier ())++instance Eq Thread where+    Thread a _ == Thread b _ = a == b++instance Hashable Thread where+    hashWithSalt salt (Thread a _) = hashWithSalt salt a++-- | The inner thread is unmasked even if you started masked.+newThreadFinally :: IO a -> (Thread -> Either SomeException a -> IO ()) -> IO Thread+newThreadFinally act cleanup = do+    bar <- newBarrier+    t <- mask_ $ forkIOWithUnmask $ \unmask -> flip finally (signalBarrier bar ()) $ do+        res <- try $ unmask act+        me <- myThreadId+        cleanup (Thread me bar) res+    return $ Thread t bar+++stopThreads :: [Thread] -> IO ()+stopThreads threads = do+    -- if a thread is in a masked action, killing it may take some time, so kill them in parallel+    bars <- sequence [do forkIO $ killThread t; return bar | Thread t bar <- threads]+    mapM_ waitBarrier bars+++-- Run both actions. If either throws an exception, both threads+-- are killed and an exception reraised.+-- Not called much, so simplicity over performance (2 threads).+withThreadsBoth :: IO a -> IO b -> IO (a, b)+withThreadsBoth act1 act2 = do+    bar1 <- newBarrier+    bar2 <- newBarrier+    parent <- myThreadId+    ignore <- newVar False+    mask $ \unmask -> do+        t1 <- forkIOWithUnmask $ \unmask -> do+            res1 :: Either SomeException a <- try $ unmask act1+            unlessM (readVar ignore) $ whenLeft res1 $ throwTo parent+            signalBarrier bar1 res1+        t2 <- forkIOWithUnmask $ \unmask -> do+            res2 :: Either SomeException b <- try $ unmask act2+            unlessM (readVar ignore) $ whenLeft res2 $ throwTo parent+            signalBarrier bar2 res2+        res :: Either SomeException (a,b) <- try $ unmask $ do+            Right v1 <- waitBarrier bar1+            Right v2 <- waitBarrier bar2+            return (v1,v2)+        writeVar ignore True+        killThread t1+        forkIO $ killThread t2+        waitBarrier bar1+        waitBarrier bar2+        either throwIO return res+++-- | Run an action in a separate thread.+--   After the first action terminates, the thread will be killed.+--   If the action raises an exception it will be rethrown on the parent thread.+withThreadSlave :: IO () -> IO a -> IO a+withThreadSlave slave act = withCleanup $ \cleanup -> do+    allocateThread cleanup slave+    act+++-- | Run the given action in a separate thread.+--   On cleanup, the thread will be killed before continuing.+--   If the action raises an exception it will be rethrown on the parent thread.+allocateThread :: Cleanup -> IO () -> IO ()+allocateThread cleanup act = do+    bar <- newBarrier+    parent <- myThreadId+    ignore <- newVar False+    void $ allocate cleanup+        (mask_ $ forkIOWithUnmask $ \unmask -> do+            res :: Either SomeException () <- try $ unmask act+            unlessM (readVar ignore) $ whenLeft res $ throwTo parent+            signalBarrier bar ()+        )+        (\t -> do writeVar ignore True; killThread t; waitBarrier bar)

@@ -1,12 +1,14 @@-{-# LANGUAGE TupleSections #-} -module General.Timing(resetTimings, addTiming, printTimings) where+module General.Timing(resetTimings, addTiming, getTimings) where  import Data.IORef import System.IO.Unsafe+import Data.Tuple.Extra import Numeric.Extra+import General.Extra import System.Time.Extra + {-# NOINLINE timer #-} timer :: IO Seconds timer = unsafePerformIO offsetTime@@ -23,12 +25,12 @@     writeIORef timings [(now, "Start")]  --- | Print all withTiming information and clear the information.-printTimings :: IO ()-printTimings = do+-- | Print all withTiming information and clear it.+getTimings :: IO [String]+getTimings = do     now <- timer-    old <- atomicModifyIORef timings ([(now, "Start")],)-    putStr $ unlines $ showTimings now $ reverse old+    old <- atomicModifyIORef timings dupe+    return $ showTimings now $ reverse old   addTiming :: String -> IO ()@@ -49,7 +51,7 @@         mx = maximum $ map snd xs         sm = sum $ map snd xs         xs = [ (name, stop - start)-             | ((start, name), stop) <- zip times $ map fst (drop 1 times) ++ [stop]]+             | ((start, name), stop) <- zipExact times $ map fst (drop 1 times) ++ [stop]]   showGap :: [(String,String)] -> [String]

@@ -54,6 +54,8 @@ import qualified Test.Self import qualified Test.SelfMake import qualified Test.Tar+import qualified Test.Targets+import qualified Test.Thread import qualified Test.Tup import qualified Test.Unicode import qualified Test.Util@@ -107,6 +109,8 @@     ,"self" * Test.Self.main     ,"selfmake" * Test.SelfMake.main     ,"tar" * Test.Tar.main+    ,"targets" * Test.Targets.main+    ,"thread" * Test.Thread.main     ,"tup" * Test.Tup.main     ,"unicode" * Test.Unicode.main     ,"util" * Test.Util.main@@ -162,7 +166,6 @@     vars <- forM [a,b,c,d] $ \xs ->         onceFork $ mapM_ (getFileInfo . fileNameFromByteString) xs     sequence_ vars-    printTimings   clean :: IO () -> IO ()

@@ -111,6 +111,7 @@             ,"time_elapsed = 1.1"             ,"old = \"\""             ,"new = \"\""+            ,"myvar = \"\""             ,"myfile = \"\""             ,"inputs = [\"\"]"             ,"files = [\"\"]"

@@ -6,7 +6,7 @@ import Development.Shake.Classes import Development.Shake.FilePath import Test.Type-import Data.List+import Data.List.Extra import Control.Monad import Control.Concurrent.Extra import General.GetOpt@@ -180,7 +180,8 @@         liftIO $ putStrLn $ let x = x in x  test build = do-    let crash args parts = assertException parts (build $ "--quiet" : args)+    -- on Windows, file paths may end up with \ separators, make sure we can still match them+    let crash args parts = assertExceptionAfter (replace "\\" "/") parts (build $ "--quiet" : args)     build ["clean"]      writeFile "chain.1" "x"

@@ -4,7 +4,6 @@ import Development.Shake import Development.Shake.Forward import Development.Shake.FilePath-import Control.Monad.Extra import Test.Type  main = testBuild test $ forwardRule $ do@@ -16,7 +15,7 @@         return o     cache $ cmd "gcc -o" ["Main" <.> exe] os -test build =-    whenM hasTracker $ do-        build ["--forward","--clean"]-        build ["--forward","-j2"]+test build = do+    b <- hasTracker+    build $ "--clean" : ["--forward" | b]+    build $ "-j2" : ["--forward" | b]

@@ -18,6 +18,11 @@     let die :: a -> a         die x = if Die `elem` args then error "Die" else x +    phony "Phony" $ return ()+    "Phony.txt" %> \out -> do+        need ["Phony"]+        copyFile' "In.txt" out+     "OutFile.txt" %> \out -> die $ copyFile' "In.txt" out      reader <- addOracleCache $ \x -> die (readFile' x)@@ -31,7 +36,7 @@  test build = do     let setIn = writeFile "In.txt"-    let outs = ["OutFile.txt","OutOracle.txt","OutFiles1.txt","OutFiles2.txt"]+    let outs = ["OutFile.txt","OutOracle.txt","OutFiles1.txt","OutFiles2.txt","Phony.txt"]     let checkOut x = mapM_ (`assertContents` x) outs      build ["clean"]

@@ -4,6 +4,7 @@ import Test.Type import Development.Shake.Internal.Core.Monad +import Data.Either.Extra import Data.IORef import Control.Concurrent import Control.Exception@@ -21,7 +22,7 @@   main = testSimple $ do-    let conv x = either (Left . fromException) Right x :: Either (Maybe ArithException) Int+    let conv x = mapLeft fromException x :: Either (Maybe ArithException) Int     let dump rw = liftIO . (=== rw) =<< getRW      -- test the basics plus exception handling@@ -74,7 +75,7 @@     res === Left Overflow     -- test for GHC bug 11555     runRAW 1 "test" (throw Overflow :: RAW Int String ()) $ \res ->-        either (Left . fromException) Right res === Left (Just Overflow)+        mapLeft fromException res === Left (Just Overflow)      -- catch works properly if continuation called multiple times     ref <- newIORef []

@@ -107,7 +107,7 @@     assertContents ".log" "#!##!"      -- check error messages are good-    let errors args err = assertException err $ build $ "--quiet" : args+    let errors args err = assertExceptionAfter (replace "\\" "/") err $ build $ "--quiet" : args      build ["--def=unit=test","unit.txt"]     errors ["unit.txt"] -- Building with an an Oracle that has been removed

@@ -7,6 +7,7 @@ import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad+import Data.Either.Extra   main = testSimple $ do@@ -36,7 +37,7 @@         res <- try_ $ runPool deterministic 3 $ \pool -> do                 add pool $ do                     waitBarrier started-                    error "pass"+                    throwIO Underflow                 add pool $                     flip finally (signalBarrier stopped ()) $ do                         signalBarrier started ()@@ -44,9 +45,7 @@                         modifyVar_ good $ const $ return False         -- note that the pool finishing means we started killing our threads         -- not that they have actually died-        case res of-            Left e | Just (ErrorCall "pass") <- fromException e -> return ()-            _ -> fail $ "Wrong type of result, got " ++ show res+        mapLeft fromException res === Left (Just Underflow)         waitBarrier stopped         assertBoolIO (readVar good) "Must be true" @@ -72,14 +71,24 @@         (=== "bssree") =<< readVar res          -- check that killing a thread pool stops the tasks, bug 545+        -- and propagates the right exception         thread <- newBarrier         died <- newBarrier         done <- newBarrier-        t <- forkIO $ flip finally (signalBarrier died ()) $ runPool deterministic 1 $ \pool ->+        t <- flip forkFinally (signalBarrier died) $ runPool deterministic 1 $ \pool ->             add pool $                 flip onException (signalBarrier done ()) $ do-                    killThread =<< waitBarrier thread+                    flip throwTo Overflow =<< waitBarrier thread                     sleep 10         signalBarrier thread t         assertWithin 1 $ waitBarrier done-        assertWithin 1 $ waitBarrier died+        res <- assertWithin 1 $ waitBarrier died+        mapLeft fromException res === Left (Just Overflow)++        -- check that killing a thread pool aborts all threads before it returns+        started <- newBarrier+        var <- newVar False+        try_ $ runPool deterministic 2 $ \pool -> do+            add pool $ try_ $ (do signalBarrier started (); sleep 10) `finally` (do sleep 1; writeVar var True)+            add pool $ do waitBarrier started; throw Overflow+        (=== True) =<< readVar var

@@ -48,20 +48,20 @@         need os         ghc $ ["-o",out] ++ os -    "//*.deps" %> \out -> do+    "**/*.deps" %> \out -> do         dep <- readFileLines $ out -<.> "dep"         let xs = map (moduleToFile "deps") dep         need xs         ds <- nubOrd . sort . (++) dep <$> concatMapM readFileLines xs         writeFileLines out ds -    "//*.dep" %> \out -> do+    "**/*.dep" %> \out -> do         src <- readFile' $ root </> "src" </> fixPaths (out -<.> "hs")         let xs = hsImports src         xs <- filterM (doesFileExist . (\x -> root </> "src" </> x) . fixPaths . moduleToFile "hs") xs         writeFileLines out xs -    ["//*.o","//*.hi"] &%> \[out,_] -> do+    ["**/*.o","**/*.hi"] &%> \[out,_] -> do         deps <- readFileLines $ out -<.> "deps"         let hs = root </> "src" </> fixPaths (out -<.> "hs")         need $ hs : map (moduleToFile "hi") deps@@ -87,7 +87,7 @@ cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]  packages = words-    ("base transformers binary unordered-containers hashable time bytestring primitive " ++-     "filepath directory process deepseq random utf8-string extra js-jquery js-flot") +++    ("base transformers binary unordered-containers hashable heaps time bytestring primitive " +++     "filepath directory process deepseq random utf8-string extra js-jquery js-flot filepattern") ++     ["old-time" | compilerVersion < makeVersion [7,6]] ++     ["semigroups" | compilerVersion < makeVersion [8,0]]

@@ -0,0 +1,54 @@+module Test.Targets(main) where++import Development.Shake+import Test.Type++main :: IO () -> IO ()+main _sleeper = do+    targets <- getTargets shakeOptions rules+    targets === expected++rules :: Rules ()+rules = do+    withTargetDocs "A phony target" $ phony "phony1" $ return ()++    "file1" %> \_ -> return ()+    ["file2", "file3"] |%> \_ -> return ()+    ["file4", "file5"] &%> \_ -> return ()++    "file6" %> \_ -> return ()+    ["file7", "file8"] |%> \_ -> return ()+    ["file9", "file10"] &%> \_ -> return ()++    withTargetDocs "Builds something really good" $ phony "phony2" $ return ()+    withTargetDocs "bad docs" $ do+        withTargetDocs "a great file" $ "file11" %> \_ -> return ()+        withTargetDocs "awesome files" $ ["file12", "file13"] &%> \_ -> return ()+        phony "Foo" $ return ()+        withoutTargets $ phony "Bar" $ return ()+++expected :: [(String, Maybe String)]+expected =+    [ "phony1" * Just "A phony target"++    , "file1" *  Nothing+    , "file2" *  Nothing+    , "file3" *  Nothing+    , "file4" *  Nothing+    , "file5" *  Nothing++    , "file6" *  Nothing+    , "file7" *  Nothing+    , "file8" *  Nothing+    , "file9" *  Nothing+    , "file10" * Nothing++    , "phony2" * Just "Builds something really good"++    , "file11" * Just "a great file"+    , "file12" * Just "awesome files"+    , "file13" * Just "awesome files"+    , "Foo" * Just "bad docs"+    ]+    where (*) = (,)

@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables, TupleSections #-}++module Test.Thread(main) where++import General.Cleanup+import General.Thread+import Control.Exception.Extra+import Control.Concurrent.Extra+import Data.Either.Extra+import Data.IORef+import Test.Type+++main = testSimple $ do+    ref <- newIORef 0+    let finish = atomicModifyIORef ref $ \x -> (x+1, ())+    let finished want = do+            got <- atomicModifyIORef ref (0,)+            want === got++    pauser <- newEmptyMVar+    let pause = takeMVar pauser+    let unpause = putMVar pauser ()++    let isAnswer x act = do+            r <- assertWithin 1 $ try_ act+            mapLeft show r === Right x+    let isException x act = do+            r <- assertWithin 1 $ try_ act+            mapLeft fromException r === Left (Just x)++    putStrLn "## allocateThread, spanwed finishes first"+    isAnswer 1 $ withCleanup $ \cleanup -> do+        allocateThread cleanup finish+        sleep 0.1+        return 1+    finished 1++    putStrLn "## allocateThread, main finishes first"+    isAnswer 1 $ withCleanup $ \cleanup -> do+        allocateThread cleanup $ (unpause >> sleep 100) `finally` finish+        pause+        return 1+    finished 1++    putStrLn "## allocateThread, spawned throws an exception"+    isException Overflow $ withCleanup $ \cleanup -> do+        allocateThread cleanup $ pause >> throw Overflow+        (unpause >> sleep 100) `finally` finish+    finished 1++    putStrLn "## allocateThread, main throws an exception"+    isException Overflow $ withCleanup $ \cleanup -> do+        allocateThread cleanup $ (unpause >> sleep 100) `finally` finish+        pause+        throw Overflow+        return 1+    finished 1++    putStrLn "## withThreadsBoth, both succeed"+    isAnswer (2,3) $ withThreadsBoth (return 2) (return 3)++    putStrLn "## withThreadsBoth, left fails"+    isException Overflow $ withThreadsBoth (pause >> throw Overflow >> return 1) ((unpause >> return 3) `finally` finish)+    finished 1++    putStrLn "## withThreadsBoth, right fails"+    isException Overflow $ withThreadsBoth ((unpause >> return 3) `finally` finish) (pause >> throw Overflow >> return 1)+    finished 1

@@ -7,7 +7,7 @@     noTest, hasTracker,     copyDirectoryChanged, copyFileChangedIO,     assertWithin,-    assertBool, assertBoolIO, assertException,+    assertBool, assertBoolIO, assertException, assertExceptionAfter,     assertContents, assertContentsUnordered, assertContentsWords,     assertExists, assertMissing,     (===),@@ -157,9 +157,11 @@   t <- tracker   return $ t == LintFSATrace +assertFail :: String -> IO a+assertFail msg = error $ "ASSERTION FAILED: " ++ msg  assertBool :: Bool -> String -> IO ()-assertBool b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg+assertBool b msg = unless b $ assertFail msg  assertBoolIO :: IO Bool -> String -> IO () assertBoolIO b msg = do b <- b; assertBool b msg@@ -180,10 +182,12 @@     b <- IO.doesFileExist file     assertBool (not b) $ "File was expected to be missing, but exists: " ++ file -assertWithin :: Seconds -> IO () -> IO ()+assertWithin :: Seconds -> IO a -> IO a assertWithin n act = do     t <- timeout n act-    when (isNothing t) $ assertBool False $ "Expected to complete within " ++ show n ++ " seconds, but did not"+    case t of+        Nothing -> assertFail $ "Expected to complete within " ++ show n ++ " seconds, but did not"+        Just v -> return v  assertContents :: FilePath -> String -> IO () assertContents file want = do@@ -202,14 +206,16 @@ assertContentsUnordered :: FilePath -> [String] -> IO () assertContentsUnordered file xs = assertContentsOn (unlines . sort . lines) file (unlines xs) -assertException :: [String] -> IO () -> IO ()-assertException parts act = do+assertExceptionAfter :: (String -> String) -> [String] -> IO () -> IO ()+assertExceptionAfter tweak parts act = do     res <- try_ act     case res of-        Left err -> let s = show err in forM_ parts $ \p ->+        Left err -> let s = tweak $ show err in forM_ parts $ \p ->             assertBool (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p         Right _ -> error $ "Expected an exception containing " ++ show parts ++ ", but succeeded" +assertException :: [String] -> IO () -> IO ()+assertException = assertExceptionAfter id  noTest :: ([String] -> IO ()) -> IO () noTest build = do