shake 0.18.5 → 0.19

raw patch · 103 files changed

+936/−870 lines, 103 filesdep ~basedep ~extra

Dependency ranges changed: base, extra

Files

• CHANGES.txt +14/−0
• shake.cabal +5/−5
• src/Development/Ninja/All.hs +16/−16
• src/Development/Ninja/Env.hs +4/−4
• src/Development/Ninja/Lexer.hs +2/−2
• src/Development/Ninja/Parse.hs +7/−7
• src/Development/Ninja/Type.hs +1/−1
• src/Development/Shake.hs +2/−47
• src/Development/Shake/Command.hs +112/−79
• src/Development/Shake/Config.hs +5/−5
• src/Development/Shake/Database.hs +10/−9
• src/Development/Shake/FilePath.hs +6/−5
• src/Development/Shake/Forward.hs +9/−9
• src/Development/Shake/Internal/Args.hs +22/−22
• src/Development/Shake/Internal/CmdOption.hs +2/−0
• src/Development/Shake/Internal/CompactUI.hs +4/−4
• src/Development/Shake/Internal/Core/Action.hs +46/−37
• src/Development/Shake/Internal/Core/Build.hs +31/−30
• src/Development/Shake/Internal/Core/Database.hs +8/−15
• src/Development/Shake/Internal/Core/Monad.hs +15/−24
• src/Development/Shake/Internal/Core/Pool.hs +5/−5
• src/Development/Shake/Internal/Core/Rules.hs +14/−22
• src/Development/Shake/Internal/Core/Run.hs +38/−37
• src/Development/Shake/Internal/Core/Storage.hs +15/−15
• src/Development/Shake/Internal/Core/Types.hs +4/−12
• src/Development/Shake/Internal/Demo.hs +7/−8
• src/Development/Shake/Internal/Derived.hs +6/−6
• src/Development/Shake/Internal/FileInfo.hs +34/−16
• src/Development/Shake/Internal/FilePattern.hs +2/−1
• src/Development/Shake/Internal/History/Cloud.hs +7/−7
• src/Development/Shake/Internal/History/Network.hs +2/−2
• src/Development/Shake/Internal/History/Serialise.hs +1/−1
• src/Development/Shake/Internal/History/Server.hs +3/−3
• src/Development/Shake/Internal/History/Shared.hs +6/−6
• src/Development/Shake/Internal/History/Symlink.hs +2/−2
• src/Development/Shake/Internal/Options.hs +13/−9
• src/Development/Shake/Internal/Paths.hs +6/−6
• src/Development/Shake/Internal/Profile.hs +2/−2
• src/Development/Shake/Internal/Progress.hs +6/−6
• src/Development/Shake/Internal/Resource.hs +18/−17
• src/Development/Shake/Internal/Rules/Directory.hs +3/−3
• src/Development/Shake/Internal/Rules/File.hs +20/−20
• src/Development/Shake/Internal/Rules/Files.hs +15/−15
• src/Development/Shake/Internal/Rules/Oracle.hs +8/−8
• src/Development/Shake/Internal/Rules/Rerun.hs +1/−1
• src/Development/Shake/Rule.hs +4/−4
• src/Development/Shake/Util.hs +3/−3
• src/General/Binary.hs +6/−6
• src/General/Chunks.hs +11/−11
• src/General/Cleanup.hs +3/−3
• src/General/EscCodes.hs +8/−7
• src/General/Extra.hs +15/−28
• src/General/Fence.hs +8/−7
• src/General/GetOpt.hs +1/−1
• src/General/Ids.hs +9/−9
• src/General/Pool.hs +17/−17
• src/General/Process.hs +31/−26
• src/General/Template.hs +6/−6
• src/General/Thread.hs +4/−4
• src/General/Timing.hs +5/−4
• src/General/Wait.hs +8/−17
• src/Paths.hs +1/−1
• src/Run.hs +5/−4
• src/Test.hs +5/−4
• src/Test/Basic.hs +3/−3
• src/Test/Batch.hs +14/−3
• src/Test/Benchmark.hs +3/−2
• src/Test/Builtin.hs +4/−4
• src/Test/C.hs +1/−1
• src/Test/Cache.hs +1/−1
• src/Test/Cleanup.hs +2/−2
• src/Test/CloseFileHandles.hs +1/−1
• src/Test/Command.hs +7/−5
• src/Test/Config.hs +2/−2
• src/Test/Database.hs +5/−5
• src/Test/Digest.hs +1/−1
• src/Test/Docs.hs +13/−13
• src/Test/Errors.hs +7/−7
• src/Test/Existence.hs +4/−4
• src/Test/FilePath.hs +3/−3
• src/Test/FilePattern.hs +16/−16
• src/Test/Forward.hs +1/−1
• src/Test/History.hs +1/−1
• src/Test/Lint.hs +1/−1
• src/Test/Monad.hs +8/−8
• src/Test/Ninja.hs +11/−3
• src/Test/Ninja/allow_directory.ninja +6/−0
• src/Test/Oracle.hs +4/−4
• src/Test/Parallel.hs +12/−4
• src/Test/Pool.hs +15/−4
• src/Test/Progress.hs +2/−2
• src/Test/Random.hs +10/−9
• src/Test/Rebuild.hs +2/−1
• src/Test/Resources.hs +2/−2
• src/Test/Self.hs +1/−1
• src/Test/SelfMake.hs +1/−1
• src/Test/Targets.hs +12/−12
• src/Test/Thread.hs +6/−6
• src/Test/Tup.hs +1/−1
• src/Test/Type.hs +38/−19
• src/Test/Unicode.hs +2/−1
• src/Test/Verbosity.hs +1/−1
• src/Test/Version.hs +3/−2

@@ -1,5 +1,19 @@ Changelog for Shake (* = breaking change) +0.19, released 2020-05-23+    #738, improve the help text+    #679, allow Ninja to depend on a directory+*   #748, close stdin by default in cmd+    #748, add NoProcessGroup and InheritStdin to cmd+    Delete stuff deprecated since 2014 - **>, ?>>, *>>, *>, |*>, &*>+    Mark askOracleWith and deprioritize as DEPRECATED+    #753, fix timing information for batch+    #746, optimise file modification times on Linux+    #746, add an instance for CmdArgument ()+    Allow getting FSATrace ByteString as a result+*   Make the FSATrace type polymorphic over the FilePath+    Speed up FSATrace parsing+    Require extra-1.6.19 0.18.5, released 2020-02-02     Use uninterruptibleMask_ to ensure all cleanup happens robustly     #742, make the Chrome profile only include the last run

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.18.5+version:            0.19 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -30,7 +30,7 @@     (e.g. compiler version). homepage:           https://shakebuild.com bug-reports:        https://github.com/ndmitchell/shake/issues-tested-with:        GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with:        GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 extra-doc-files:     CHANGES.txt     README.md@@ -90,7 +90,7 @@         bytestring,         deepseq >= 1.1,         directory >= 1.2.7.0,-        extra >= 1.6.14,+        extra >= 1.6.19,         filepath,         filepattern,         hashable >= 1.1.2.3,@@ -216,7 +216,7 @@         bytestring,         deepseq >= 1.1,         directory,-        extra >= 1.6.14,+        extra >= 1.6.19,         filepath,         filepattern,         file-embed >= 0.0.11,@@ -337,7 +337,7 @@         bytestring,         deepseq >= 1.1,         directory,-        extra >= 1.6.14,+        extra >= 1.6.19,         filepath,         filepattern,         hashable >= 1.1.2.3,

@@ -38,9 +38,9 @@ runNinja _ file args (Just "compdb") = do     dir <- getCurrentDirectory     Ninja{..} <- parse file =<< newEnv-    rules <- return $ Map.fromList [r | r <- rules, BS.unpack (fst r) `elem` args]+    rules<- pure $ Map.fromList [r | r <- rules, BS.unpack (fst r) `elem` args]     -- the build items are generated in reverse order, hence the reverse-    let xs = [(a,b,file,rule) | (a,b@Build{..}) <- reverse $ multiples ++ map (first return) singles+    let xs = [(a,b,file,rule) | (a,b@Build{..}) <- reverse $ multiples ++ map (first pure) singles                               , Just rule <- [Map.lookup ruleName rules], file:_ <- [depsNormal]]     xs <- forM xs $ \(out,Build{..},file,Rule{..}) -> do         -- the order of adding new environment variables matters@@ -51,29 +51,29 @@         forM_ buildBind $ \(a,b) -> addEnv env a b         addBinds env ruleBind         commandline <- fmap BS.unpack $ askVar env $ BS.pack "command"-        return $ CompDb dir commandline $ BS.unpack file+        pure $ CompDb dir commandline $ BS.unpack file     putStr $ printCompDb xs-    return Nothing+    pure Nothing  runNinja _ _ _ (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x  runNinja restart file args Nothing = do     addTiming "Ninja parse"     ninja@Ninja{..} <- parse file =<< newEnv-    return $ Just $ do-        phonys <- return $ Map.fromList phonys-        needDeps <- return $ needDeps ninja phonys -- partial application-        singles <- return $ Map.fromList $ map (first filepathNormalise) singles-        multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map filepathNormalise) multiples, x <- xs]-        rules <- return $ Map.fromList rules+    pure $ Just $ do+        phonys<- pure $ Map.fromList phonys+        needDeps<- pure $ needDeps ninja phonys -- partial application+        singles<- pure $ Map.fromList $ map (first filepathNormalise) singles+        multiples<- pure $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map filepathNormalise) multiples, x <- xs]+        rules<- pure $ Map.fromList rules         pools <- fmap Map.fromList $ forM ((BS.pack "console",1):pools) $ \(name,depth) ->             (name,) <$> newResource (BS.unpack name) depth          action $ do             -- build the .ninja files, if they change, restart the build-            before <- liftIO $ mapM (getFileInfo . fileNameFromString) sources+            before <- liftIO $ mapM (getFileInfo False . fileNameFromString) sources             need sources-            after <- liftIO $ mapM (getFileInfo . fileNameFromString) sources+            after <- liftIO $ mapM (getFileInfo False . fileNameFromString) sources             if before /= after then                 runAfter restart              else@@ -156,13 +156,13 @@         neededBS xs         -- now try and statically validate needed will never fail         -- first find which dependencies are generated files-        xs <- return $ filter (`Map.member` builds) xs+        xs<- pure $ filter (`Map.member` builds) xs         -- now try and find them as dependencies         -- performance note: allDependencies generates lazily, and difference consumes lazily,         -- with the property that in the common case it won't generate much of the list at all         let bad = xs `difference` allDependencies build         case bad of-            [] -> return ()+            [] -> pure ()             xs -> throwM $ errorStructured                 ("Lint checking error - " ++                     (if length xs == 1 then "file in deps is" else "files in deps are") ++@@ -252,7 +252,7 @@         -- Using the "cmd" program adds overhead (I measure 7ms), and a limit of 8191 characters,         -- but is the most robust, requiring no additional escaping.         ([Shell], s, [])-    | (cmd,s) <- word1 s, map toUpper cmd `elem` ["CMD","CMD.EXE"], ("/c",s) <- word1 s =+    | (cmd,s) <- word1 s, upper cmd `elem` ["CMD","CMD.EXE"], ("/c",s) <- word1 s =         -- Given "cmd.exe /c <something>" we translate to Shell, which adds cmd.exe         -- (looked up on the current path) and /c to the front. CMake uses this rule a lot.         -- Adding quotes around pieces are /c goes very wrong.@@ -260,7 +260,7 @@     | otherwise =         -- It's a long command line which doesn't call "cmd /c". We reverse the escaping         -- Haskell applies, but each argument will still gain quotes around it.-        let xs = splitArgs s in ([], head $ xs ++ [""], drop 1 xs)+        let xs = splitArgs s in ([], headDef "" xs, drop1 xs)   data State

@@ -16,11 +16,11 @@   newEnv :: IO (Env k v)-newEnv = do ref <- newIORef Map.empty; return $ Env ref Nothing+newEnv = do ref <- newIORef Map.empty; pure $ Env ref Nothing   scopeEnv :: Env k v -> IO (Env k v)-scopeEnv e = do ref <- newIORef Map.empty; return $ Env ref $ Just e+scopeEnv e = do ref <- newIORef Map.empty; pure $ Env ref $ Just e   addEnv :: (Eq k, Hashable k) => Env k v -> k -> v -> IO ()@@ -31,9 +31,9 @@ askEnv (Env ref e) k = do     mp <- readIORef ref     case Map.lookup k mp of-        Just v -> return $ Just v+        Just v -> pure $ Just v         Nothing | Just e <- e -> askEnv e k-        _ -> return Nothing+        _ -> pure Nothing  fromEnv :: Env k v -> IO (Map.HashMap k v) fromEnv (Env ref _) = readIORef ref

@@ -45,7 +45,7 @@         i = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do             let start = castPtr ptr :: S             let end = go start-            return $! Ptr end `minusPtr` start+            pure $! Ptr end `minusPtr` start          go s@(Ptr a) | c == '\0' || f c = a                      | otherwise = go (next s)@@ -59,7 +59,7 @@         i = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do             let start = castPtr ptr :: S             let end = go start-            return $! Ptr end `minusPtr` start+            pure $! Ptr end `minusPtr` start          go s@(Ptr a) | f c = a                      | otherwise = go (next s)

@@ -35,18 +35,18 @@         binds <- mapM (\(a,b) -> (a,) <$> askExpr env b) binds         let (normal,implicit,orderOnly) = splitDeps deps         let build = Build rule env normal implicit orderOnly binds-        return $+        pure $             if rule == BS.pack "phony" then ninja{phonys = [(x, normal ++ implicit ++ orderOnly) | x <- outputs] ++ phonys}             else if length outputs == 1 then ninja{singles = (head outputs, build) : singles}             else ninja{multiples = (outputs, build) : multiples}     LexRule name ->-        return ninja{rules = (name, Rule binds) : rules}+        pure ninja{rules = (name, Rule binds) : rules}     LexDefault xs -> do         xs <- mapM (askExpr env) xs-        return ninja{defaults = xs ++ defaults}+        pure ninja{defaults = xs ++ defaults}     LexPool name -> do         depth <- getDepth env binds-        return ninja{pools = (name, depth) : pools}+        pure ninja{pools = (name, depth) : pools}     LexInclude expr -> do         file <- askExpr env expr         parseFile (BS.unpack file) env ninja@@ -56,7 +56,7 @@         parseFile (BS.unpack file) e ninja     LexDefine a b -> do         addBind env a b-        return ninja+        pure ninja     LexBind a _ ->         error $ "Unexpected binding defining " ++ BS.unpack a @@ -71,9 +71,9 @@  getDepth :: Env Str Str -> [(Str, Expr)] -> IO Int getDepth env xs = case lookup (BS.pack "depth") xs of-    Nothing -> return 1+    Nothing -> pure 1     Just x -> do         x <- askExpr env x         case BS.readInt x of-            Just (i, n) | BS.null n -> return i+            Just (i, n) | BS.null n -> pure i             _ -> error $ "Could not parse depth field in pool, got: " ++ BS.unpack x

@@ -25,7 +25,7 @@ askExpr :: Env Str Str -> Expr -> IO Str askExpr e = f     where f (Exprs xs) = BS.concat <$> mapM f xs-          f (Lit x) = return x+          f (Lit x) = pure x           f (Var x) = askVar e x  askVar :: Env Str Str -> Str -> IO Str

@@ -110,16 +110,12 @@     batch,     reschedule,     -- * Deprecated-    (*>), (|*>), (&*>),-    (**>), (*>>), (?>>),     askOracleWith,     deprioritize,     pattern Quiet, pattern Normal, pattern Loud, pattern Chatty,     putLoud, putNormal, putQuiet     ) where -import Prelude(Maybe, FilePath, Double, String) -- Since GHC 7.10 duplicates *>- -- I would love to use module export in the above export list, but alas Haddock -- then shows all the things that are hidden in the docs, which is terrible. import Control.Monad.IO.Class@@ -221,53 +217,11 @@   ------------------------------------------------------------------------ DEPRECATED SINCE 0.13, MAY 2014--infix 1 **>, ?>>, *>>---{-# DEPRECATED (**>) "Use |%> instead" #-}--- | /Deprecated:/ Alias for '|%>'.-(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(**>) = (|%>)--{-# DEPRECATED (?>>) "Use &?> instead" #-}--- | /Deprecated:/ Alias for '&?>'.-(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()-(?>>) = (&?>)--{-# DEPRECATED (*>>) "Use &%> instead" #-}--- | /Deprecated:/ Alias for '&%>'.-(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-(*>>) = (&%>)--------------------------------------------------------------------------- DEPRECATED SINCE 0.14, MAY 2014--infix 1 *>, |*>, &*>--{-# DEPRECATED (*>) "Use %> instead" #-}--- | /Deprecated:/ Alias for '%>'. Note that @*>@ clashes with a Prelude operator in GHC 7.10.-(*>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()-(*>) = (%>)--{-# DEPRECATED (|*>) "Use |%> instead" #-}--- | /Deprecated:/ Alias for '|%>'.-(|*>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(|*>) = (|%>)--{-# DEPRECATED (&*>) "Use &%> instead" #-}--- | /Deprecated:/ Alias for '&%>'.-(&*>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-(&*>) = (&%>)------------------------------------------------------------------------ -- DEPRECATED SINCE 0.16.1, NOV 2017  -- | /Deprecated:/ Replace @'askOracleWith' q a@ by @'askOracle' q@ --   since the 'RuleResult' type family now fixes the result type.+{-# DEPRECATED askOracleWith "Use 'askOracle q' instead of 'askOracleWith q a', the result value is now unnecessary" #-} askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a askOracleWith question _ = askOracle question @@ -275,6 +229,7 @@ -- DEPRECATED SINCE 0.18.4, JUL 2019  -- | /Deprecated:/ Alias for 'reschedule'.+{-# DEPRECATED deprioritize "Use 'reschedule' instead" #-} deprioritize :: Double -> Action () deprioritize = reschedule 

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeOperators, ScopedTypeVariables, NamedFieldPuns #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable, RecordWildCards #-} @@ -39,6 +41,7 @@ import System.IO.Unsafe(unsafeInterleaveIO) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.UTF8 as UTF8 import General.Extra import General.Process import Prelude@@ -69,7 +72,7 @@ addPath pre post = do     args <- liftIO getEnvironment     let (path,other) = partition ((== "PATH") . (if isWindows then upper else id) . fst) args-    return $ Env $+    pure $ Env $         [("PATH",intercalate [searchPathSeparator] $ pre ++ post) | null path] ++         [(a,intercalate [searchPathSeparator] $ pre ++ [b | b /= ""] ++ post) | (a,b) <- path] ++         other@@ -88,7 +91,7 @@ addEnv :: MonadIO m => [(String, String)] -> m CmdOption addEnv extra = do     args <- liftIO getEnvironment-    return $ Env $ extra ++ filter (\(a,_) -> a `notElem` map fst extra) args+    pure $ Env $ extra ++ filter (\(a,_) -> a `notElem` map fst extra) args   data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving (Eq,Show)@@ -112,7 +115,8 @@     | ResultTime Double     | ResultLine String     | ResultProcess PID-    | ResultFSATrace [FSATrace]+    | ResultFSATrace [FSATrace FilePath]+    | ResultFSATraceBS [FSATrace BS.ByteString]       deriving (Eq,Show)  data PID = PID0 | PID ProcessHandle@@ -127,9 +131,15 @@     ,args :: [String]     } deriving Show -class MonadIO m => MonadTempDir m where runWithTempDir :: (FilePath -> m a) -> m a-instance MonadTempDir IO where runWithTempDir = IO.withTempDir-instance MonadTempDir Action where runWithTempDir = withTempDir+class MonadIO m => MonadTempDir m where+    runWithTempDir :: (FilePath -> m a) -> m a+    runWithTempFile :: (FilePath -> m a) -> m a+instance MonadTempDir IO where+    runWithTempDir = IO.withTempDir+    runWithTempFile = IO.withTempFile+instance MonadTempDir Action where+    runWithTempDir = withTempDir+    runWithTempFile = withTempFile  --------------------------------------------------------------------- -- DEAL WITH Shell@@ -143,9 +153,9 @@     | Shell `elem` opts = do         -- put our UserCommand first, as the last one wins, and ours is lowest priority         let userCmdline = unwords $ prog : args-        params <- return params{opts = UserCommand userCmdline : filter (/= Shell) opts}+        params <- pure params{opts = UserCommand userCmdline : filter (/= Shell) opts} -        prog <- liftIO $ if isFSATrace params then copyFSABinary prog else return prog+        prog <- liftIO $ if isFSATrace params then copyFSABinary prog else pure prog         let realCmdline = unwords $ prog : args         if not isWindows then             call params{prog = "/bin/sh", args = ["-c",realCmdline]}@@ -162,12 +172,12 @@ -- DEAL WITH FSATrace  isFSATrace :: Params -> Bool-isFSATrace Params{..} = ResultFSATrace [] `elem` results || any isFSAOptions opts+isFSATrace Params{..} = any isResultFSATrace  results || any isFSAOptions opts  -- Mac disables tracing on system binaries, so we copy them over, yurk copyFSABinary :: FilePath -> IO FilePath copyFSABinary prog-    | not isMac = return prog+    | not isMac = pure prog     | otherwise = do         progFull <- findExecutable prog         case progFull of@@ -179,8 +189,8 @@                 unlessM (doesFileExist fake) $ do                     createDirectoryRecursive $ takeDirectory fake                     copyFile x fake-                return fake-            _ -> return prog+                pure fake+            _ -> pure prog  removeOptionFSATrace     :: MonadTempDir m@@ -192,26 +202,31 @@     | ResultProcess PID0 `elem` results =         -- This is a bad state to get into, you could technically just ignore the tracing, but that's a bit dangerous         liftIO $ errorIO "Asyncronous process execution combined with FSATrace is not support"-    | otherwise = runWithTempDir $ \dir -> do-        let file = dir </> "fsatrace.txt"+    | otherwise = runWithTempFile $ \file -> do         liftIO $ writeFile file "" -- ensures even if we fail before fsatrace opens the file, we can still read it         params <- liftIO $ fsaParams file params         res <- call params{opts = UserCommand (showCommandForUser2 prog args) : filter (not . isFSAOptions) opts}-        cwd <- liftIO getCurrentDirectory-        fsaRes <- liftIO $ parseFSA <$> readFileUTF8' file-        return $ replace [ResultFSATrace []] [ResultFSATrace fsaRes] res+        fsaResBS <- liftIO $ parseFSA <$> BS.readFile file+        let fsaRes = map (fmap UTF8.toString) fsaResBS+        pure $ flip map res $ \case+            ResultFSATrace [] -> ResultFSATrace fsaRes+            ResultFSATraceBS [] -> ResultFSATraceBS fsaResBS+            x -> x     where-        fsaFlags = fromMaybe "rwmdqt" fsaOptions-        fsaOptions = last $ Nothing : [Just x | FSAOptions x <- opts]+        fsaFlags = lastDef "rwmdqt" [x | FSAOptions x <- opts]          fsaParams file Params{..} = do             prog <- copyFSABinary prog-            return params{prog = "fsatrace", args = fsaFlags : file : "--" : prog : args }+            pure params{prog = "fsatrace", args = fsaFlags : file : "--" : prog : args }   isFSAOptions FSAOptions{} = True isFSAOptions _ = False +isResultFSATrace ResultFSATrace{} = True+isResultFSATrace ResultFSATraceBS{} = True+isResultFSATrace _ = False+ addFSAOptions :: String -> [CmdOption] -> [CmdOption] addFSAOptions x opts | any isFSAOptions opts = map f opts     where f (FSAOptions y) = FSAOptions $ nubOrd $ y ++ x@@ -222,34 +237,46 @@ -- | The results produced by @fsatrace@. All files will be absolute paths. --   You can get the results for a 'cmd' by requesting a value of type --   @['FSATrace']@.-data FSATrace+data FSATrace a     = -- | Writing to a file-      FSAWrite FilePath+      FSAWrite a     | -- | Reading from a file-      FSARead FilePath+      FSARead a     | -- | Deleting a file-      FSADelete FilePath+      FSADelete a     | -- | Moving, arguments destination, then source-      FSAMove FilePath FilePath+      FSAMove a a     | -- | Querying\/stat on a file-      FSAQuery FilePath+      FSAQuery a     | -- | Touching a file-      FSATouch FilePath-      deriving (Show,Eq,Ord,Data,Typeable)+      FSATouch a+      deriving (Show,Eq,Ord,Data,Typeable,Functor)   -- | Parse the 'FSATrace' entries, ignoring anything you don't understand.-parseFSA :: String -> [FSATrace]-parseFSA = mapMaybe f . lines-    where f ('w':'|':xs) = Just $ FSAWrite xs-          f ('r':'|':xs) = Just $ FSARead xs-          f ('d':'|':xs) = Just $ FSADelete xs-          f ('m':'|':xs) | (xs,'|':ys) <- break (== '|') xs = Just $ FSAMove xs ys-          f ('q':'|':xs) = Just $ FSAQuery xs-          f ('t':'|':xs) = Just $ FSATouch xs-          f _ = Nothing+parseFSA :: BS.ByteString -> [FSATrace BS.ByteString]+parseFSA = mapMaybe (f . dropR) . BS.lines+    where+        -- deal with CRLF on Windows+        dropR x = case BS.unsnoc x of+            Just (x, '\r') -> x+            _ -> x +        f x+            | Just (k, x) <- BS.uncons x+            , Just ('|', x) <- BS.uncons x =+                case k of+                    'w' -> Just $ FSAWrite x+                    'r' -> Just $ FSARead  x+                    'd' -> Just $ FSADelete x+                    'm' | (xs, ys) <- BS.break (== '|') x, Just ('|',ys) <- BS.uncons ys ->+                        Just $ FSAMove xs ys+                    'q' -> Just $ FSAQuery x+                    't' -> Just $ FSATouch x+                    _ -> Nothing+            | otherwise = Nothing + --------------------------------------------------------------------- -- ACTION EXPLICIT OPERATION @@ -257,9 +284,9 @@ commandExplicitAction :: Partial => Params -> Action [Result] commandExplicitAction oparams = do     ShakeOptions{shakeCommandOptions,shakeRunCommands,shakeLint,shakeLintInside} <- getShakeOptions-    params@Params{..} <- return $ oparams{opts = shakeCommandOptions ++ opts oparams}+    params@Params{..}<- pure $ oparams{opts = shakeCommandOptions ++ opts oparams} -    let skipper act = if null results && not shakeRunCommands then return [] else act+    let skipper act = if null results && not shakeRunCommands then pure [] else act      let verboser act = do             let cwd = listToMaybe $ reverse [x | Cwd x <- opts]@@ -272,7 +299,7 @@      let tracer act = do             -- note: use the oparams - find a good tracing before munging it for shell stuff-            let msg = last $ defaultTraced oparams : [x | Traced x <- opts]+            let msg = lastDef (defaultTraced oparams) [x | Traced x <- opts]             if msg == "" then liftIO act else traced msg act      let async = ResultProcess PID0 `elem` results@@ -286,13 +313,12 @@             xs <- liftIO $ filterM doesFileExist [x | FSARead x <- pxs]             cwd <- liftIO getCurrentDirectory             temp <- fixPaths cwd xs-            liftIO $ print ("AutoDeps", pxs, cwd, xs, temp) -- DEBUGGING             unsafeAllowApply $ need temp-            return res+            pure res          fixPaths cwd xs = liftIO $ do-            xs <- return $ map toStandard xs-            xs <- return $ filter (\x -> any (`isPrefixOf` x) shakeLintInside) xs+            xs<- pure $ map toStandard xs+            xs<- pure $ filter (\x -> any (`isPrefixOf` x) shakeLintInside) xs             mapM (\x -> fromMaybe x <$> makeRelativeEx cwd x) xs          fsalint act = do@@ -303,7 +329,7 @@             cwd <- liftIO getCurrentDirectory             trackRead  =<< fixPaths cwd =<< existing reader xs             trackWrite =<< fixPaths cwd =<< existing writer xs-            return res+            pure res      skipper $ tracker $ \params -> verboser $ tracer $ commandExplicitIO params @@ -318,7 +344,7 @@ -- | Given a very explicit set of CmdOption, translate them to a General.Process structure commandExplicitIO :: Partial => Params -> IO [Result] commandExplicitIO params = removeOptionShell params $ \params -> removeOptionFSATrace params $ \Params{..} -> do-    let (grabStdout, grabStderr) = both or $ unzip $ flip map results $ \r -> case r of+    let (grabStdout, grabStderr) = both or $ unzip $ flip map results $ \case             ResultStdout{} -> (True, False)             ResultStderr{} -> (False, True)             ResultStdouterr{} -> (True, True)@@ -326,40 +352,43 @@      optEnv <- resolveEnv opts     let optCwd = mergeCwd [x | Cwd x <- opts]-    let optStdin = flip mapMaybe opts $ \x -> case x of+    let optStdin = flip mapMaybe opts $ \case             Stdin x -> Just $ SrcString x             StdinBS x -> Just $ SrcBytes x             FileStdin x -> Just $ SrcFile x+            InheritStdin -> Just SrcInherit             _ -> Nothing     let optBinary = BinaryPipes `elem` opts     let optAsync = ResultProcess PID0 `elem` results     let optTimeout = listToMaybe $ reverse [x | Timeout x <- opts]-    let optWithStdout = last $ False : [x | WithStdout x <- opts]-    let optWithStderr = last $ True : [x | WithStderr x <- opts]+    let optWithStdout = lastDef False [x | WithStdout x <- opts]+    let optWithStderr = lastDef True [x | WithStderr x <- opts]     let optFileStdout = [x | FileStdout x <- opts]     let optFileStderr = [x | FileStderr x <- opts]-    let optEchoStdout = last $ (not grabStdout && null optFileStdout) : [x | EchoStdout x <- opts]-    let optEchoStderr = last $ (not grabStderr && null optFileStderr) : [x | EchoStderr x <- opts]+    let optEchoStdout = lastDef (not grabStdout && null optFileStdout) [x | EchoStdout x <- opts]+    let optEchoStderr = lastDef (not grabStderr && null optFileStderr) [x | EchoStderr x <- opts]     let optRealCommand = showCommandForUser2 prog args-    let optUserCommand = last $ optRealCommand : [x | UserCommand x <- opts]+    let optUserCommand = lastDef optRealCommand [x | UserCommand x <- opts]     let optCloseFds = CloseFileHandles `elem` opts+    let optProcessGroup = NoProcessGroup `notElem` opts -    let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; return (a, (\(LBS x) -> f x) <$> b)+    let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; pure (a, (\(LBS x) -> f x) <$> b)         buf Str{} | optBinary = bufLBS (Str . LBS.unpack)-        buf Str{} = do x <- newBuffer; return ([DestString x | not optAsync], Str . concat <$> readBuffer x)-        buf LBS{} = do x <- newBuffer; return ([DestBytes x | not optAsync], LBS . LBS.fromChunks <$> readBuffer x)+        buf Str{} = do x <- newBuffer; pure ([DestString x | not optAsync], Str . concat <$> readBuffer x)+        buf LBS{} = do x <- newBuffer; pure ([DestBytes x | not optAsync], LBS . LBS.fromChunks <$> readBuffer x)         buf BS {} = bufLBS (BS . BS.concat . LBS.toChunks)-        buf Unit  = return ([], return Unit)+        buf Unit  = pure ([], pure Unit)     (dStdout, dStderr, resultBuild) :: ([[Destination]], [[Destination]], [Double -> ProcessHandle -> ExitCode -> IO Result]) <--        fmap unzip3 $ forM results $ \r -> case r of-            ResultCode _ -> return ([], [], \_ _ ex -> return $ ResultCode ex)-            ResultTime _ -> return ([], [], \dur _ _ -> return $ ResultTime dur)-            ResultLine _ -> return ([], [], \_ _ _ -> return $ ResultLine optUserCommand)-            ResultProcess _ -> return ([], [], \_ pid _ -> return $ ResultProcess $ PID pid)-            ResultStdout    s -> do (a,b) <- buf s; return (a , [], \_ _ _ -> fmap ResultStdout b)-            ResultStderr    s -> do (a,b) <- buf s; return ([], a , \_ _ _ -> fmap ResultStderr b)-            ResultStdouterr s -> do (a,b) <- buf s; return (a , a , \_ _ _ -> fmap ResultStdouterr b)-            ResultFSATrace _ -> return ([], [], \_ _ _ -> return $ ResultFSATrace []) -- filled in elsewhere+        fmap unzip3 $ forM results $ \case+            ResultCode _ -> pure ([], [], \_ _ ex -> pure $ ResultCode ex)+            ResultTime _ -> pure ([], [], \dur _ _ -> pure $ ResultTime dur)+            ResultLine _ -> pure ([], [], \_ _ _ -> pure $ ResultLine optUserCommand)+            ResultProcess _ -> pure ([], [], \_ pid _ -> pure $ ResultProcess $ PID pid)+            ResultStdout    s -> do (a,b) <- buf s; pure (a , [], \_ _ _ -> fmap ResultStdout b)+            ResultStderr    s -> do (a,b) <- buf s; pure ([], a , \_ _ _ -> fmap ResultStderr b)+            ResultStdouterr s -> do (a,b) <- buf s; pure (a , a , \_ _ _ -> fmap ResultStdouterr b)+            ResultFSATrace _ -> pure ([], [], \_ _ _ -> pure $ ResultFSATrace []) -- filled in elsewhere+            ResultFSATraceBS _ -> pure ([], [], \_ _ _ -> pure $ ResultFSATraceBS []) -- filled in elsewhere      exceptionBuffer <- newBuffer     po <- resolvePath ProcessOpts@@ -370,6 +399,7 @@         ,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr && not optAsync] ++ concat dStderr         ,poAsync = optAsync         ,poCloseFds = optCloseFds+        ,poGroup = optProcessGroup         }     (dur,(pid,exit)) <- duration $ process po     if exit == ExitSuccess || ResultCode ExitSuccess `elem` results then@@ -378,12 +408,11 @@         exceptionBuffer <- readBuffer exceptionBuffer         let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]         cwd <- case optCwd of-            Nothing -> return ""+            Nothing -> pure ""             Just v -> do-                v <- canonicalizePath v `catchIO` const (return v)-                return $ "Current directory: " ++ v ++ "\n"-        -- FIXME: switch to errorIO once extra-1.6.18 is available everywhere-        liftIO $ error $+                v <- canonicalizePath v `catchIO` const (pure v)+                pure $ "Current directory: " ++ v ++ "\n"+        liftIO $ errorIO $             "Development.Shake." ++ funcName ++ ", system command failed\n" ++             "Command line: " ++ optRealCommand ++ "\n" ++             (if optRealCommand /= optUserCommand then "Original command line: " ++ optUserCommand ++ "\n" else "") ++@@ -401,9 +430,9 @@ -- | Apply all environment operations, to produce a new environment to use. resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)]) resolveEnv opts-    | null env, null addEnv, null addPath, null remEnv = return Nothing+    | null env, null addEnv, null addPath, null remEnv = pure Nothing     | otherwise = Just . unique . tweakPath . (++ addEnv) . filter (flip notElem remEnv . fst) <$>-                  if null env then getEnvironment else return (concat env)+                  if null env then getEnvironment else pure (concat env)     where         env = [x | Env x <- opts]         addEnv = [(x,y) | AddEnv x y <- opts]@@ -434,24 +463,24 @@     new <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath path) progExe     old2 <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath pathOld) progExe -    switch <- return $ case () of+    switch<- pure $ case () of         _ | path == pathOld -> False -- The state I can see hasn't changed           | Nothing <- new -> False -- I have nothing to offer           | Nothing <- old -> True -- I failed last time, so this must be an improvement           | Just old <- old, Just new <- new, equalFilePath old new -> False -- no different           | Just old <- old, Just old2 <- old2, equalFilePath old old2 -> True -- I could predict last time           | otherwise -> False-    return $ case new of+    pure $ case new of         Just new | switch -> po{poCommand = RawCommand new args}         _ -> po-resolvePath po = return po+resolvePath po = pure po   -- | Given a list of directories, and a file name, return the complete path if you can find it. --   Like findExecutable, but with a custom PATH. findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath) findExecutableWith path x = flip firstJustM (map (</> x) path) $ \s ->-    ifM (doesFileExist s) (return $ Just s) (return Nothing)+    ifM (doesFileExist s) (pure $ Just s) (pure Nothing)   ---------------------------------------------------------------------@@ -496,7 +525,7 @@ -- timer act = do --     ('CmdTime' t, 'CmdLine' x, r) <- act --     liftIO $ putStrLn $ \"Command \" ++ x ++ \" took \" ++ show t ++ \" seconds\"---     return r+--     pure r -- -- run :: IO () -- run = timer $ 'cmd' \"ghc --version\"@@ -545,9 +574,12 @@ instance CmdResult CmdTime where     cmdResult = ([ResultTime 0], \[ResultTime x] -> CmdTime x) -instance CmdResult [FSATrace] where+instance CmdResult [FSATrace FilePath] where     cmdResult = ([ResultFSATrace []], \[ResultFSATrace x] -> x) +instance CmdResult [FSATrace BS.ByteString] where+    cmdResult = ([ResultFSATraceBS []], \[ResultFSATraceBS x] -> x)+ instance CmdString a => CmdResult (Stdout a) where     cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> Stdout $ b x) @@ -705,9 +737,10 @@ class IsCmdArgument a where     -- | Conversion to a CmdArgument     toCmdArgument :: a -> CmdArgument+instance IsCmdArgument () where toCmdArgument = mempty instance IsCmdArgument String where toCmdArgument = CmdArgument . map Right . words instance IsCmdArgument [String] where toCmdArgument = CmdArgument . map Right-instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . return . Left+instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . pure . Left instance IsCmdArgument [CmdOption] where toCmdArgument = CmdArgument . map Left instance IsCmdArgument CmdArgument where toCmdArgument = id instance IsCmdArgument a => IsCmdArgument (Maybe a) where toCmdArgument = maybe mempty toCmdArgument

@@ -51,7 +51,7 @@     mapM_ (uncurry (Ninja.addEnv env) . (UTF8.fromString *** UTF8.fromString)) vars     Ninja.parse file env     mp <- Ninja.fromEnv env-    return $ Map.fromList $ map (UTF8.toString *** UTF8.toString) $ Map.toList mp+    pure $ Map.fromList $ map (UTF8.toString *** UTF8.toString) $ Map.toList mp   newtype Config = Config String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)@@ -70,7 +70,7 @@         liftIO $ readConfigFile file     addOracle $ \(Config x) -> Map.lookup x <$> mp ()     addOracle $ \(ConfigKeys ()) -> sort . Map.keys <$> mp ()-    return ()+    pure ()   -- | Specify the values to use with 'getConfig', generally prefer@@ -78,9 +78,9 @@ --   of variables outside 'Action'. usingConfig :: Map.HashMap String String -> Rules () usingConfig mp = do-    addOracle $ \(Config x) -> return $ Map.lookup x mp-    addOracle $ \(ConfigKeys ()) -> return $ sort $ Map.keys mp-    return ()+    addOracle $ \(Config x) -> pure $ Map.lookup x mp+    addOracle $ \(ConfigKeys ()) -> pure $ sort $ Map.keys mp+    pure ()   -- | Obtain the value of a configuration variable, returns 'Nothing' to indicate the variable

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}  -- | Lower-level primitives to drive Shake, which are wrapped into the@@ -62,28 +63,28 @@             withOpen use "shakeOpenDatabase" id $ \_ ->                 ShakeDatabase use <$> open cleanup opts (rules >> defaultRules)     let free = do-            modifyVar_ use $ \x -> case x of+            modifyVar_ use $ \case                     Using s -> throwM $ errorStructured "Error when calling shakeOpenDatabase close function, currently running" [("Existing call", Just s)] ""-                    _ -> return Closed+                    _ -> pure Closed             clean-    return (alloc, free)+    pure (alloc, free)  withOpen :: Var UseState -> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a withOpen var name final act = mask $ \restore -> do-    o <- modifyVar var $ \x -> case x of+    o <- modifyVar var $ \case         Using s -> throwM $ errorStructured ("Error when calling " ++ name ++ ", currently running") [("Existing call", Just s)] ""         Closed -> throwM $ errorStructured ("Error when calling " ++ name ++ ", already closed") [] ""-        o@Open{} -> return (Using name, o)+        o@Open{} -> pure (Using name, o)     let clean = writeVar var $ final o     res <- restore (act o) `onException` clean     clean-    return res+    pure res  -- | Declare that a just-openned database will be used to call 'shakeRunDatabase' at most once. --   If so, an optimisation can be applied to retain less memory. shakeOneShotDatabase :: ShakeDatabase -> IO () shakeOneShotDatabase (ShakeDatabase use _) =-    withOpen use "shakeOneShotDatabase" (\o -> o{openOneShot=True}) $ \_ -> return ()+    withOpen use "shakeOneShotDatabase" (\o -> o{openOneShot=True}) $ \_ -> pure ()  -- | Given some options and rules, create a 'ShakeDatabase' that can be used to run --   executions.@@ -142,9 +143,9 @@             reset s         (refs, as) <- fmap unzip $ forM as $ \a -> do             ref <- newIORef Nothing-            return (ref, liftIO . writeIORef ref . Just =<< a)+            pure (ref, liftIO . writeIORef ref . Just =<< a)         after <- run s openOneShot $ map void as         results <- mapM readIORef refs         case sequence results of-            Just result -> return (result, after)+            Just result -> pure (result, after)             Nothing -> throwM $ errorInternal "Expected all results were written, but some where not"

@@ -14,6 +14,7 @@  import System.Directory (canonicalizePath) import System.Info.Extra+import Data.List.Extra import qualified System.FilePath as Native  import System.FilePath hiding@@ -34,7 +35,7 @@ -- > dropDirectory1 "aaa" == "" -- > dropDirectory1 "" == "" dropDirectory1 :: FilePath -> FilePath-dropDirectory1 = drop 1 . dropWhile (not . isPathSeparator)+dropDirectory1 = drop1 . dropWhile (not . isPathSeparator)   -- | Take the first component of a 'FilePath'. Should only be used on@@ -76,12 +77,12 @@ makeRelativeEx :: FilePath -> FilePath -> IO (Maybe FilePath) makeRelativeEx pathA pathB     | isRelative makeRelativePathAPathB =-        return (Just makeRelativePathAPathB)+        pure (Just makeRelativePathAPathB)     | otherwise = do         a' <- canonicalizePath pathA         b' <- canonicalizePath pathB         if takeDrive a' /= takeDrive b'-            then return Nothing+            then pure Nothing             else Just <$> makeRelativeEx' a' b'     where         makeRelativePathAPathB = makeRelative pathA pathB@@ -91,11 +92,11 @@             let rel = makeRelative a b                 parent = takeDirectory a             if isRelative rel-                then return rel+                then pure rel                 else if a /= parent                     then do                         parentToB <- makeRelativeEx' parent b-                        return (".." </> parentToB)+                        pure (".." </> parentToB)                      -- Impossible: makeRelative should have succeeded in finding                     -- a relative path once `a == "/"`.

@@ -55,7 +55,7 @@ import Development.Shake.Command import Development.Shake.Classes import Development.Shake.FilePath-import Data.IORef+import Data.IORef.Extra import Data.Either import Data.Typeable import Data.List.Extra@@ -89,7 +89,7 @@ encode' = BS.concat . LBS.toChunks . encode  decode' :: Binary a => BS.ByteString -> a-decode' = decode . LBS.fromChunks . return+decode' = decode . LBS.fromChunks . pure  type instance RuleResult Forward = Forward @@ -112,14 +112,14 @@         fail "When running in forward mode you must set shakeLintInside to specify where to detect dependencies"     addBuiltinRule noLint noIdentity $ \k old mode ->         case old of-            Just old | mode == RunDependenciesSame -> return $ RunResult ChangedNothing old (decode' old)+            Just old | mode == RunDependenciesSame -> pure $ 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, " ++ show k                     Just act -> do                         new <- act-                        return $ RunResult ChangedRecomputeSame (encode' new) new+                        pure $ RunResult ChangedRecomputeSame (encode' new) new     action act  -- | Given a 'ShakeOptions', set the options necessary to execute in forward mode.@@ -133,10 +133,10 @@ --   (e.g. the action is a closure), you should call 'cacheActionWith' being explicit about what is captured. 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, ())+    liftIO $ atomicModifyIORef_ forwards $ Map.insert key (mkForward <$> action)     res <- apply1 key-    liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete key mp, ())-    return $ unForward res+    liftIO $ atomicModifyIORef_ forwards $ Map.delete key+    pure $ unForward res  newtype With a = With a     deriving (Typeable, Binary, Show)@@ -147,7 +147,7 @@ cacheActionWith key argument action = do     cacheAction (With argument) $ do         alwaysRerun-        return argument+        pure argument     cacheAction key $ do         apply1 $ mkForward $ With argument         action@@ -163,7 +163,7 @@ cache cmd = do     let CmdArgument args = cmd     let isDull ['-',_] = True; isDull _ = False-    let name = head $ filter (not . isDull) (drop 1 $ rights args) ++ ["unknown"]+    let name = headDef "unknown" $ filter (not . isDull) $ drop1 $ rights args     cacheAction (Command $ toStandard name ++ " #" ++ upper (showHex (abs $ hash $ show args) "")) cmd  newtype Command = Command String

@@ -29,7 +29,7 @@ import Control.Exception.Extra import Control.Monad import Data.Either-import Data.List+import Data.List.Extra import Data.Maybe import System.Directory.Extra import System.Environment@@ -80,7 +80,7 @@ -- * @main _make/henry.txt@ will not build @neil.txt@ or @emily.txt@, but will instead build @henry.txt@. shakeArgs :: ShakeOptions -> Rules () -> IO () shakeArgs opts rules = shakeArgsWith opts [] f-    where f _ files = return $ Just $ if null files then rules else want files >> withoutActions rules+    where f _ files = pure $ Just $ if null files then rules else want files >> withoutActions rules   -- | A version of 'shakeArgs' with more flexible handling of command line arguments.@@ -115,7 +115,7 @@ -- data Flags = DistCC deriving Eq -- flags = [Option \"\" [\"distcc\"] (NoArg $ Right DistCC) \"Run distributed.\"] ----- main = 'shakeArgsWith' 'shakeOptions' flags $ \\flags targets -> return $ Just $ do+-- main = 'shakeArgsWith' 'shakeOptions' flags $ \\flags targets -> pure $ Just $ do --     let compiler = if DistCC \`elem\` flags then \"distcc\" else \"gcc\" --     let rules = do --         \"*.o\" '%>' \\out -> do@@ -146,7 +146,7 @@         progressReplays = [x | ProgressReplay x <- flagsExtra]         progressRecords = [x | ProgressRecord x <- flagsExtra]         changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]-        printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]+        printDirectory = lastDef False [x | PrintDirectory x <- flagsExtra]         shareRemoves = [x | ShareRemove x <- flagsExtra]         oshakeOpts = foldl' (flip ($)) baseOpts flagsShake     lintInside <- mapM canonicalizePath $ shakeLintInside oshakeOpts@@ -160,8 +160,8 @@     let putWhenLn v msg = putWhen v $ msg ++ "\n"     let showHelp long = do             progName <- getProgName-            (targets, helpSuffix) <- if not long then return ([], []) else-                handleSynchronous (\e -> do putWhenLn Info $ "Failure to collect targets: " ++ show e; return ([], [])) $ do+            (targets, helpSuffix) <- if not long then pure ([], []) else+                handleSynchronous (\e -> do putWhenLn Info $ "Failure to collect targets: " ++ show e; pure ([], [])) $ do                     -- run the rules as simply as we can                     rs <- rules shakeOpts [] []                     case rs of@@ -169,8 +169,8 @@                             xs <- getTargets shakeOpts rs                             helpSuffix <- getHelpSuffix shakeOpts rs                             evaluate $ force (["  - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs], helpSuffix)-                        _ -> return ([], [])-            changes <- return $+                        _ -> pure ([], [])+            changes<- pure $                 let as = shakeOptionsFields baseOpts                     bs = shakeOptionsFields oshakeOpts                 in ["  - " ++ lbl ++ ": " ++ v1 ++ " => " ++ v2 | long, ((lbl, v1), (_, v2)) <- zip as bs, v1 /= v2]@@ -199,7 +199,7 @@      else if not $ null progressReplays then do         dat <- forM progressReplays $ \file -> do             src <- readFile file-            return (file, map read $ lines src)+            pure (file, map read $ lines src)         forM_ (if null $ shakeReport shakeOpts then ["-"] else shakeReport shakeOpts) $ \file -> do             putWhenLn Info $ "Writing report to " ++ file             writeProgressReport file dat@@ -208,30 +208,30 @@         start <- offsetTime         initDataDirectory -- must be done before we start changing directory         let redir = maybe id withCurrentDirectory changeDirectory-        shakeOpts <- if null progressRecords then return shakeOpts else do+        shakeOpts <- if null progressRecords then pure shakeOpts else do             t <- offsetTime-            return shakeOpts{shakeProgress = \p ->+            pure shakeOpts{shakeProgress = \p ->                 void $ withThreadsBoth (shakeProgress shakeOpts p) $-                    progressDisplay 1 (const $ return ()) $ do+                    progressDisplay 1 (const $ pure ()) $ do                         p <- p                         t <- t                         forM_ progressRecords $ \file ->                             appendFile file $ show (t,p) ++ "\n"-                        return p+                        pure p             }         (ran,shakeOpts,res) <- redir $ do             when printDirectory $ do                 curdir <- getCurrentDirectory                 putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'"             (shakeOpts, ui) <- do-                let compact = last $ No : [x | Compact x <- flagsExtra]-                use <- if compact == Auto then checkEscCodes else return $ compact == Yes+                let compact = lastDef No [x | Compact x <- flagsExtra]+                use <- if compact == Auto then checkEscCodes else pure $ compact == Yes                 if use                     then second withThreadSlave <$> compactUI shakeOpts-                    else return (shakeOpts, id)+                    else pure (shakeOpts, id)             rules <- rules shakeOpts user files             ui $ case rules of-                Nothing -> return (False, shakeOpts, Right ())+                Nothing -> pure (False, shakeOpts, Right ())                 Just (shakeOpts, rules) -> do                     res <- try_ $ shake shakeOpts $                         if NoBuild `elem` flagsExtra then@@ -249,10 +249,10 @@                             withoutActions rules                         else                             rules-                    return (True, shakeOpts, res)+                    pure (True, shakeOpts, res)          if not ran || shakeVerbosity shakeOpts < Info || NoTime `elem` flagsExtra then-            either throwIO return res+            either throwIO pure res          else             let esc = if shakeColor shakeOpts then escape else flip const             in case res of@@ -338,8 +338,8 @@     ,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 "B" ["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 "B" ["rebuild"] (optArg "PATTERN" $ \x s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNow, fromMaybe "**" x)]}) "If required, these files will rebuild even if nothing has changed."+    ,opts $ Option ""  ["no-rebuild"] (optArg "PATTERN" $ \x s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNormal, fromMaybe "**" x)]}) "If required, these files will rebuild only if things have changed (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."     ,opts $ Option "r" ["report","profile"] (optArg "FILE" $ \x s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]}) "Write out profiling information [to report.html]."@@ -357,7 +357,7 @@     ,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 ""  ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ pure ()}) "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."

@@ -29,4 +29,6 @@     | UserCommand String -- ^ The command the user thinks about, before any munging. Defaults to the actual command.     | FSAOptions String -- ^ Options to @fsatrace@, a list of strings with characters such as @\"r\"@ (reads) @\"w\"@ (writes). Defaults to @\"rwmdqt\"@ if the output of @fsatrace@ is required.     | CloseFileHandles -- ^ Before starting the command in the child process, close all file handles except stdin, stdout, stderr in the child process. Uses @close_fds@ from package process and comes with the same caveats, i.e. runtime is linear with the maximum number of open file handles (@RLIMIT_NOFILE@, see @man 2 getrlimit@ on Linux).+    | NoProcessGroup -- ^ Don't run the process in its own group. Required when running @docker@. Will mean that process timeouts and asyncronous exceptions may not properly clean up child processes.+    | InheritStdin -- ^ Cause the stdin from the parent to be inherited. Might also require NoProcessGroup on Linux. Ignored if you explicitly pass a stdin.       deriving (Eq,Ord,Show,Data,Typeable)

@@ -13,7 +13,7 @@ import Control.Exception import General.Thread import General.EscCodes-import Data.IORef+import Data.IORef.Extra import Control.Monad.Extra  @@ -64,9 +64,9 @@     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, ())+    let tweak = atomicModifyIORef_ ref     time <- offsetTime-    opts <- return $ opts+    opts <- pure $ 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@@ -74,4 +74,4 @@         ,shakeVerbosity = Error         }     let tick = do t <- time; mask_ $ putStr =<< atomicModifyIORef ref (display t)-    return (opts, forever (tick >> sleep 0.4) `finally` tick)+    pure (opts, forever (tick >> sleep 0.4) `finally` tick)

@@ -28,10 +28,11 @@ import System.Directory import System.FilePattern import System.FilePattern.Directory+import System.Time.Extra import Control.Concurrent.Extra import Data.Maybe import Data.Tuple.Extra-import Data.IORef+import Data.IORef.Extra import Data.List.Extra import Numeric.Extra import General.Extra@@ -67,7 +68,7 @@     putRW s2     res <- fromAction m     modifyRW undo-    return res+    pure res   ---------------------------------------------------------------------@@ -78,12 +79,12 @@ --   then do nothing with it. shakeException :: Global -> Stack -> SomeException -> IO ShakeException shakeException Global{globalOptions=ShakeOptions{..},..} stk e = case fromException e of-    Just (e :: ShakeException) -> return e+    Just (e :: ShakeException) -> pure e     Nothing -> do-        e <- return $ exceptionStack stk e+        e<- pure $ exceptionStack stk e         when (shakeStaunch && shakeVerbosity >= Error) $             globalOutput Error $ show e ++ "Continuing due to staunch mode"-        return e+        pure e   actionBracketEx :: Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c@@ -92,18 +93,18 @@     (v, key) <- liftIO $ mask_ $ do         v <- alloc         key <- liftIO $ register globalCleanup $ void $ free v-        return (v, key)+        pure (v, key)     res <- Action $ catchRAW (fromAction $ act v) $ \e -> liftIO (release key) >> throwRAW e     liftIO $ if runOnSuccess then release key else unprotect key-    return res+    pure res  -- | If an exception is raised by the 'Action', perform some 'IO' then reraise the exception. actionOnException :: Action a -> IO b -> Action a-actionOnException act free = actionBracketEx False (return ()) (const free) (const act)+actionOnException act free = actionBracketEx False (pure ()) (const free) (const act)  -- | After an 'Action', perform some 'IO', even if there is an exception. actionFinally :: Action a -> IO b -> Action a-actionFinally act free = actionBracket (return ()) (const free) (const act)+actionFinally act free = actionBracket (pure ()) (const free) (const act)  -- | Like `bracket`, but where the inner operation is of type 'Action'. Usually used as --   @'actionBracket' alloc free use@.@@ -152,7 +153,7 @@ runAfter :: IO () -> Action () runAfter op = do     Global{..} <- Action getRO-    liftIO $ atomicModifyIORef globalAfter $ \ops -> (op:ops, ())+    liftIO $ atomicModifyIORef_ globalAfter (op:)   ---------------------------------------------------------------------@@ -257,7 +258,7 @@     let trace = newTrace msg start stop     liftIO $ evaluate $ rnf trace     Action $ modifyRW $ \s -> s{localTraces = trace : localTraces s}-    return res+    pure res   ---------------------------------------------------------------------@@ -320,7 +321,7 @@         let used = Set.filter (not . ignore) $ Set.fromList localTrackRead          -- check Read 4a-        bad <- return $ Set.toList $ used `Set.difference` Set.fromList deps+        bad<- pure $ Set.toList $ used `Set.difference` Set.fromList deps         unless (null bad) $ do             let n = length bad             throwM $ errorStructured@@ -338,9 +339,9 @@                 ""          -- check Write 3-        bad <- return $ filter (not . ignore) $ Set.toList $ Set.fromList localTrackWrite+        bad<- pure $ filter (not . ignore) $ Set.toList $ Set.fromList localTrackWrite         unless (null bad) $-            liftIO $ atomicModifyIORef globalTrackAbsent $ \old -> ([(fromMaybe k top, k) | k <- bad] ++ old, ())+            liftIO $ atomicModifyIORef_ globalTrackAbsent ([(fromMaybe k top, k) | k <- bad] ++)   -- | Allow any matching key recorded with 'lintTrackRead' or 'lintTrackWrite' in this action,@@ -366,12 +367,12 @@         ""  lintWatch :: [FilePattern] -> IO (String -> IO ())-lintWatch [] = return $ const $ return ()+lintWatch [] = pure $ const $ pure () lintWatch pats = do     let op = getDirectoryFiles "." pats -- cache parsing of the pats-    let record = do xs <- op; forM xs $ \x -> (x,) <$> getFileInfo (fileNameFromString x)+    let record = do xs <- op; forM xs $ \x -> (x,) <$> getFileInfo False (fileNameFromString x)     old <- record-    return $ \msg -> do+    pure $ \msg -> do         now <- record         when (old /= now) $ throwIO $ errorStructured             "Lint checking error - watched files have changed"@@ -391,7 +392,7 @@ lookupDependencies :: Database -> Key -> IO [Depends] lookupDependencies db k = do     Just (Ready r) <- getValueFromKey db k-    return $ depends r+    pure $ depends r   -- | This rule should not be cached or recorded in the history because it makes use of untracked dependencies@@ -425,7 +426,7 @@     Local{localDepends=pre} <- getRW     res <- fromAction act     modifyRW $ \s -> s{localDepends=pre}-    return res+    pure res   ---------------------------------------------------------------------@@ -436,15 +437,15 @@ newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v) newCacheIO (act :: k -> Action v) = do     var :: Var (Map.HashMap k (Fence IO (Either SomeException ([Depends],v)))) <- newVar Map.empty-    return $ \key ->+    pure $ \key ->         join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of-            Just bar -> return $ (,) mp $ do+            Just bar -> pure $ (,) mp $ do                 (offset, (deps, v)) <- actionFenceRequeue bar                 Action $ modifyRW $ \s -> addDiscount offset $ s{localDepends = deps ++ localDepends s}-                return v+                pure v             Nothing -> do                 bar <- newFence-                return $ (Map.insert key bar mp,) $ do+                pure $ (Map.insert key bar mp,) $ do                     Local{localDepends=pre} <- Action getRW                     res <- Action $ tryRAW $ fromAction $ act key                     case res of@@ -455,7 +456,7 @@                             Local{localDepends=post} <- Action getRW                             let deps = dropEnd (length pre) post                             liftIO $ signalFence bar $ Right (deps, v)-                            return v+                            pure v   -- | Run an action without counting to the thread limit, typically used for actions that execute@@ -473,14 +474,14 @@     -- we start a new thread, giving up ours, to ensure the thread count goes down     (wait, res) <- actionAlwaysRequeue res     Action $ modifyRW $ addDiscount wait-    return res+    pure res   -- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism. parallel :: [Action a] -> Action [a] -- Note: There is no parallel_ unlike sequence_ because there is no stack benefit to doing so-parallel [] = return []-parallel [x] = return <$> x+parallel [] = pure []+parallel [x] = pure <$> x parallel acts = do     Global{..} <- Action getRO @@ -492,12 +493,12 @@             Action $ modifyRW localClearMutable             res <- act             old <- Action getRW-            return (old, res)+            pure (old, res)     (wait, res) <- actionFenceSteal =<< liftIO (exceptFence waits)     liftIO $ atomicWriteIORef done True     let (waits, locals, results) = unzip3 $ map (\(a,(b,c)) -> (a,b,c)) res     Action $ modifyRW $ \root -> addDiscount (wait - sum waits) $ localMergeMutable root locals-    return results+    pure results   -- | Batch different outputs into a single 'Action', typically useful when a command has a high@@ -516,7 +517,7 @@ -- -- @ -- 'batch' 3 (\"*.out\" 'Development.Shake.%>')---     (\\out -> do 'Development.Shake.need' [out '-<.>' \"in\"]; return out)+--     (\\out -> do 'Development.Shake.need' [out '-<.>' \"in\"]; pure out) --     (\\outs -> 'Development.Shake.cmd' "build-multiple" [out '-<.>' \"in\" | out \<- outs]) -- @ --@@ -537,7 +538,7 @@     | mx <= 0 = error $ "Can't call batchable with <= 0, you used " ++ show mx     | mx == 1 = pred $ \a -> do b <- one a; many [b]     | otherwise = do-        todo :: IORef (Int, [(b, Local, Fence IO (Either SomeException Local))]) <- liftIO $ newIORef (0, [])+        todo :: IORef (Int, [(b, Local, Fence IO (Either SomeException (Seconds, Local)))]) <- liftIO $ newIORef (0, [])         pred $ \a -> do             b <- one a             fence <- liftIO newFence@@ -545,15 +546,15 @@             local <- Action getRW             count <- liftIO $ atomicModifyIORef todo $ \(count, bs) -> let i = count+1 in ((i, (b,local,fence):bs), i)             requeue todo (==) count-            (wait, local2) <- actionFenceRequeue fence-            Action $ modifyRW $ \root -> addDiscount wait $ localMergeMutable root [local2]+            (wait, (cost, local2)) <- actionFenceRequeue fence+            Action $ modifyRW $ \root -> addDiscount (wait - cost) $ localMergeMutable root [local2]     where         -- When changing by one, only trigger on (==) so we don't have lots of waiting pool entries         -- When changing by many, trigger on (>=) because we don't hit all edges         requeue todo trigger count             | count `trigger` mx = addPoolWait_ PoolResume $ go todo             | count `trigger` 1  = addPoolWait_ PoolBatch  $ go todo-            | otherwise = return ()+            | otherwise = pure ()          go todo = do             -- delete at most mx from the batch@@ -568,9 +569,17 @@                     -- make sure we are using one of the local's that we are computing                     -- we things like stack, blockApply etc. work as expected                     modifyRW $ const $ localClearMutable $ snd3 $ head now+                    start <- liftIO offsetTime                     fromAction $ many $ map fst3 now-                    res <- getRW-                    return res{localDiscount = localDiscount res / intToDouble (length now)} -- divide the batch fairly+                    end <- liftIO start++                    -- accounting for time is tricky, we spend time T, over N jobs+                    -- so want to charge everyone for T / N time+                    -- but that also means we need to subtract localDiscount so we don't apply that to all+                    rw <- getRW+                    let t = end - localDiscount rw+                    let n = intToDouble (length now)+                    pure (t / n, rw{localDiscount = 0})                 liftIO $ mapM_ (flip signalFence res . thd3) now  @@ -580,7 +589,7 @@ --   Only useful if the results are being interactively reported or consumed. reschedule :: Double -> Action () reschedule x = do-    (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ return ()+    (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ pure ()     Action $ modifyRW $ addDiscount wait  

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables, NamedFieldPuns, GADTs #-} {-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-} @@ -49,7 +50,7 @@         let changeValue = case v of                 Ready r -> Just $ "    = " ++ showBracket (result r) ++ " " ++ (if built r == changed r then "(changed)" else "(unchanged)")                 _ -> Nothing-        return $ changeStatus ++ maybe "" ("\n" ++) changeValue+        pure $ changeStatus ++ maybe "" ("\n" ++) changeValue     setMem db i k v  @@ -64,7 +65,7 @@ getDatabaseValueGeneric k = do     Global{..} <- Action getRO     Just status <- liftIO $ getValueFromKey globalDatabase k-    return $ getResult status+    pure $ getResult status   ---------------------------------------------------------------------@@ -97,7 +98,7 @@ buildOne global@Global{..} stack database i k r = case addStack i k stack of     Left e -> do         quickly $ setIdKeyStatus global database i k $ mkError e-        return $ Left e+        pure $ Left e     Right stack -> Later $ \continue -> do         setIdKeyStatus global database i k (Running (NoShow continue) r)         let go = buildRunMode global stack database r@@ -107,7 +108,7 @@                     let val = fmap runValue res                     res <- liftIO $ getKeyValueFromId database i                     w <- case res of-                        Just (_, Running (NoShow w) _) -> return w+                        Just (_, Running (NoShow w) _) -> pure w                         -- We used to be able to hit here, but we fixed it by ensuring the thread pool workers are all                         -- dead _before_ any exception bubbles up                         _ -> throwM $ errorInternal $ "expected Waiting but got " ++ maybe "nothing" (statusType . snd) res ++ ", key " ++ show k@@ -115,7 +116,7 @@                     w val                 case res of                     Right RunResult{..} | runChanged /= ChangedNothing -> setDisk database i k $ Loaded runValue{result=runStore}-                    _ -> return ()+                    _ -> pure ()     where         mkError e = Failed e $ if globalOneShot then Nothing else r @@ -124,9 +125,9 @@ buildRunMode :: Global -> Stack -> Database -> Maybe (Result a) -> Wait Locked RunMode buildRunMode global stack database me = do     changed <- case me of-        Nothing -> return True+        Nothing -> pure True         Just me -> buildRunDependenciesChanged global stack database me-    return $ if changed then RunDependenciesChanged else RunDependenciesSame+    pure $ if changed then RunDependenciesChanged else RunDependenciesSame   -- | Have the dependencies changed@@ -151,7 +152,7 @@     Local{localStack, localBlockApply} <- Action getRW     let stack = addCallStack callStack localStack -    let tk = typeKey $ head $ ks ++ [newKey ()] -- always called at non-empty so never see () key+    let tk = typeKey $ headDef (newKey ()) ks -- always called at non-empty so never see () key     whenJust localBlockApply $ throwM . errorNoApply tk (show <$> listToMaybe ks)      let database = globalDatabase@@ -160,13 +161,13 @@         wait <- runWait $ do             x <- firstJustWaitUnordered (fmap (either Just (const Nothing)) . lookupOne global stack database) $ nubOrd is             case x of-                Just e -> return $ Left e+                Just e -> pure $ Left e                 Nothing -> quickly $ Right <$> mapM (fmap (\(Just (_, Ready r)) -> fst $ result r) . liftIO . getKeyValueFromId database) is-        return (is, wait)+        pure (is, wait)     Action $ modifyRW $ \s -> s{localDepends = Depends is : localDepends s}      case wait of-        Now vs -> either throwM return vs+        Now vs -> either throwM pure vs         _ -> do             offset <- liftIO offsetTime             vs <- Action $ captureRAW $ \continue ->@@ -174,7 +175,7 @@                     liftIO $ addPool (if isLeft x then PoolException else PoolResume) globalPool $ continue x             offset <- liftIO offset             Action $ modifyRW $ addDiscount offset-            return vs+            pure vs   runKey@@ -189,7 +190,7 @@     let tk = typeKey k     BuiltinRule{..} <- case Map.lookup tk globalRules of         Nothing -> throwM $ errorNoRuleToBuildType tk (Just $ show k) Nothing-        Just r -> return r+        Just r -> pure r      let s = (newLocal stack shakeVerbosity){localBuiltinVersion = builtinVersion}     time <- offsetTime@@ -203,7 +204,7 @@             globalRuleFinished k             producesCheck -        Action $ fmap (res,) getRW) $ \x -> case x of+        Action $ fmap (res,) getRW) $ \case             Left e ->                 continue . Left . toException =<< shakeException global stack e             Right (RunResult{..}, Local{..})@@ -232,7 +233,7 @@ apply :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] apply [] =     -- if they do [] then we don't test localBlockApply, but unclear if that should be an error or not-    return []+    pure [] apply ks =     fmap (map fromValue) $ Action $ stepRAW (callStackFull, map newKey ks) @@ -240,7 +241,7 @@ -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible, --   use 'apply' to allow parallelism. apply1 :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value-apply1 = withFrozenCallStack $ fmap head . apply . return+apply1 = withFrozenCallStack $ fmap head . apply . pure   @@ -256,7 +257,7 @@ historyLoad (Ver -> ver) = do     global@Global{..} <- Action getRO     Local{localStack, localBuiltinVersion} <- Action getRW-    if isNothing globalShared && isNothing globalCloud then return Nothing else do+    if isNothing globalShared && isNothing globalCloud then pure Nothing else do         key <- liftIO $ evaluate $ fromMaybe (error "Can't call historyLoad outside a rule") $ topStack localStack         let database = globalDatabase         res <- liftIO $ runLocked database $ runWait $ do@@ -265,19 +266,19 @@                     let identify = runIdentify globalRules k . fst . result                     either (const Nothing) identify <$> lookupOne global localStack database i             x <- case globalShared of-                Nothing -> return Nothing+                Nothing -> pure Nothing                 Just shared -> lookupShared shared ask key localBuiltinVersion ver             x <- case x of-                Just res -> return $ Just res+                Just res -> pure $ Just res                 Nothing -> case globalCloud of-                    Nothing -> return Nothing+                    Nothing -> pure Nothing                     Just cloud -> lookupCloud cloud ask key localBuiltinVersion ver             case x of-                Nothing -> return Nothing+                Nothing -> pure Nothing                 Just (a,b,c) -> quickly $ Just . (a,,c) <$> mapM (mapM $ mkId database) b         -- FIXME: If running with cloud and shared, and you got a hit in cloud, should also add it to shared         res <- case res of-            Now x -> return x+            Now x -> pure x             _ -> do                 offset <- liftIO offsetTime                 res <- Action $ captureRAW $ \continue ->@@ -285,14 +286,14 @@                         liftIO $ addPool PoolResume globalPool $ continue $ Right x                 offset <- liftIO offset                 Action $ modifyRW $ addDiscount offset-                return res+                pure res         case res of-            Nothing -> return Nothing+            Nothing -> pure Nothing             Just (res, deps, restore) -> do-                liftIO $ globalDiagnostic $ return $ "History hit for " ++ show key+                liftIO $ globalDiagnostic $ pure $ "History hit for " ++ show key                 liftIO restore                 Action $ modifyRW $ \s -> s{localDepends = reverse $ map Depends deps}-                return (Just res)+                pure (Just res)   -- | Is the history enabled, returns 'True' if you have a 'shakeShare' or 'shakeCloud',@@ -301,7 +302,7 @@ historyIsEnabled = Action $ do     Global{..} <- getRO     Local{localHistory} <- getRW-    return $ localHistory && (isJust globalShared || isJust globalCloud)+    pure $ localHistory && (isJust globalShared || isJust globalCloud)   -- | Save a value to the history. Record the version of any user rule@@ -326,14 +327,14 @@             -- can do this without the DB lock, since it reads things that are stable             forNothingM (reverse localDepends) $ \(Depends is) -> forNothingM is $ \i -> do                 Just (k, Ready r) <- getKeyValueFromId globalDatabase i-                return $ (k,) <$> runIdentify globalRules k (fst $ result r)+                pure $ (k,) <$> runIdentify globalRules k (fst $ result r)         let k = topStack localStack         case deps of-            Nothing -> liftIO $ globalDiagnostic $ return $ "Dependency with no identity for " ++ show k+            Nothing -> liftIO $ globalDiagnostic $ pure $ "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+                liftIO $ globalDiagnostic $ pure $ "History saved for " ++ show k   runIdentify :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> Maybe BS.ByteString

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}  module Development.Shake.Internal.Core.Database(@@ -18,18 +17,12 @@ import Control.Concurrent.Extra import Control.Monad.IO.Class import qualified General.Ids as Ids--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail-#endif+import Prelude   newtype Locked a = Locked (IO a)-    deriving (Functor, Applicative, Monad, MonadIO-#if __GLASGOW_HASKELL__ >= 800-             ,MonadFail-#endif-        )+    deriving (Functor, Applicative, Monad, MonadIO, MonadFail)  runLocked :: DatabasePoly k v -> Locked b -> IO b runLocked db (Locked act) = withLock (lock db) act@@ -58,7 +51,7 @@     xs <- Ids.toList status     intern <- newIORef $ Intern.fromList [(k, i) | (i, (k,_)) <- xs]     lock <- newLock-    return Database{..}+    pure Database{..}   ---------------------------------------------------------------------@@ -68,7 +61,7 @@ getValueFromKey Database{..} k = do     is <- readIORef intern     case Intern.lookup k is of-        Nothing -> return Nothing+        Nothing -> pure Nothing         Just i -> fmap snd <$> Ids.lookup status i  -- Returns Nothing only if the Id was serialised previously but then the Id disappeared@@ -84,7 +77,7 @@ getIdFromKey :: (Eq k, Hashable k) => DatabasePoly k v -> IO (k -> Maybe Id) getIdFromKey Database{..} = do     is <- readIORef intern-    return $ flip Intern.lookup is+    pure $ flip Intern.lookup is   ---------------------------------------------------------------------@@ -95,13 +88,13 @@ mkId Database{..} k = liftIO $ do     is <- readIORef intern     case Intern.lookup k is of-        Just i -> return i+        Just i -> pure i         Nothing -> do-            (is, i) <- return $ Intern.add k is+            (is, i)<- pure $ Intern.add k is             -- make sure to write it into Status first to maintain Database invariants             Ids.insert status i (k, vDefault)             writeIORef' intern is-            return i+            pure i   setMem :: DatabasePoly k v -> Id -> k -> v -> Locked ()

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections, GeneralizedNewtypeDeriving #-}  module Development.Shake.Internal.Core.Monad(@@ -16,11 +16,8 @@ import Control.Monad import System.IO import Data.Semigroup-import Prelude--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail-#endif+import Prelude   data RAW k v ro rw a where@@ -54,14 +51,8 @@ instance MonadIO (RAW k v ro rw) where     liftIO = LiftIO -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 instance MonadFail (RAW k v ro rw) where     fail = liftIO . Control.Monad.Fail.fail-#endif-#if __GLASGOW_HASKELL__ >= 808-instance MonadFail (RAW k v ro rw) where-    fail = liftIO . Prelude.fail-#endif  instance Semigroup a => Semigroup (RAW k v ro rw a) where     (<>) a b = (<>) <$> a <*> b@@ -81,10 +72,10 @@  assertOnce :: MonadIO m => String -> (a -> m b) -> IO (a -> m b) assertOnce msg k-    | not assertOnceCheck = return k+    | not assertOnceCheck = pure k     | otherwise = do         ref <- liftIO $ newIORef False-        return $ \v -> do+        pure $ \v -> do             liftIO $ join $ atomicModifyIORef ref $ \old -> (True,) $ when old $ do                 hPutStrLn stderr "FATAL ERROR: assertOnce failed"                 Prelude.fail $ "assertOnce failed: " ++ msg@@ -136,10 +127,10 @@             Bind a b -> go a $ \a -> sio a $ \a -> go (b a) k             LiftIO act -> flush $ do v <- act; k $ pure v -            GetRO -> k $ return ro-            GetRW -> flush $ k . return =<< readIORef rw-            PutRW x -> flush $ writeIORef rw x >> k (return ())-            ModifyRW f -> flush $ modifyIORef' rw f >> k (return ())+            GetRO -> k $ pure ro+            GetRW -> flush $ k . pure =<< readIORef rw+            PutRW x -> flush $ writeIORef rw x >> k (pure ())+            ModifyRW f -> flush $ modifyIORef' rw f >> k (pure ())              CatchRAW m hdl -> flush $ do                 hdl <- assertOnce "CatchRAW" hdl@@ -154,11 +145,11 @@                 f <- assertOnce "CaptureRAW" f                 old <- readIORef handler                 writeIORef handler throwIO-                f $ \x -> case x of+                f $ \case                     Left e -> old e                     Right v -> do                         writeIORef handler old-                        k (return v) `catch_` \e -> do unflush; ($ e) =<< readIORef handler+                        k (pure v) `catch_` \e -> do unflush; ($ e) =<< readIORef handler   newtype SIO a = SIO (IO a)@@ -174,7 +165,7 @@ addStep (Steps ref) k = do     out <- newIORef $ throwImpure $ errorInternal "Monad, addStep not flushed"     modifyIORef ref ((k,out):)-    return $ SIO $ readIORef out+    pure $ SIO $ readIORef out  unflushSteps :: Steps k v -> IO () unflushSteps (Steps ref) = writeIORef ref []@@ -183,10 +174,10 @@ flushSteps (Steps ref) = do     v <- reverse <$> readIORef ref     case v of-        [] -> return Nothing+        [] -> pure Nothing         xs -> do             writeIORef ref []-            return $ Just $ \step -> do+            pure $ Just $ \step -> do                 vs <- step $ map fst xs                 liftIO $ zipWithM_ writeIORef (map snd xs) vs @@ -215,7 +206,7 @@ catchRAW = CatchRAW  tryRAW :: RAW k v ro rw a -> RAW k v ro rw (Either SomeException a)-tryRAW m = catchRAW (fmap Right m) (return . Left)+tryRAW m = catchRAW (fmap Right m) (pure . Left)  throwRAW :: Exception e => e -> RAW k v ro rw a -- Note that while we could directly pass this to the handler@@ -226,7 +217,7 @@ finallyRAW a undo = do     r <- catchRAW a (\e -> undo >> throwRAW e)     undo-    return r+    pure r   ---------------------------------------------------------------------

@@ -28,9 +28,9 @@     rw <- Action getRW     liftIO $ do         fence <- newFence-        let act2 = do offset <- liftIO offsetTime; res <- act; offset <- liftIO offset; return (offset, res)+        let act2 = do offset <- liftIO offsetTime; res <- act; offset <- liftIO offset; pure (offset, res)         addPool pri globalPool $ runAction ro rw act2 $ signalFence fence-        return fence+        pure fence  -- | Like 'addPoolWait' but doesn't provide a fence to wait for it - a fire and forget version. --   Warning: If Action throws an exception, it would be lost, so must be executed with try. Seconds are not tracked.@@ -38,7 +38,7 @@ addPoolWait_ pri act = do     ro@Global{..} <- Action getRO     rw <- Action getRW-    liftIO $ addPool pri globalPool $ runAction ro rw act $ \_ -> return ()+    liftIO $ addPool pri globalPool $ runAction ro rw act $ \_ -> pure ()   actionFenceSteal :: Fence IO (Either SomeException a) -> Action (Seconds, a)@@ -46,7 +46,7 @@     res <- liftIO $ testFence fence     case res of         Just (Left e) -> Action $ throwRAW e-        Just (Right v) -> return (0, v)+        Just (Right v) -> pure (0, v)         Nothing -> Action $ captureRAW $ \continue -> do             offset <- offsetTime             waitFence fence $ \v -> do@@ -62,7 +62,7 @@     res <- liftIO $ testFence fence     case fmap op res of         Just (Left e) -> throwRAW e-        Just (Right v) -> return (0, v)+        Just (Right v) -> pure (0, v)         Nothing -> do             Global{..} <- getRO             offset <- liftIO offsetTime

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, NamedFieldPuns #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-}@@ -40,11 +39,8 @@ import Data.Binary.Put import Data.Binary.Get import General.ListBuilder-import Prelude--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail-#endif+import Prelude  import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Monad@@ -69,9 +65,9 @@     Global{..} <- Action getRO     let UserRuleVersioned versioned rules = fromMaybe mempty $ TMap.lookup globalUserRules     let ver = if versioned then Nothing else Just $ Ver 0-    let items = head $ (map snd $ reverse $ groupSort $ f (Ver 0) Nothing rules) ++ [[]]+    let items = headDef [] $ map snd $ reverse $ groupSort $ f (Ver 0) Nothing rules     let err = errorMultipleRulesMatch (typeOf key) (show key) (map snd3 items)-    return (ver, map (\(Ver v,_,x) -> (v,x)) items, err)+    pure (ver, map (\(Ver v,_,x) -> (v,x)) items, err)     where         f :: Ver -> Maybe Double -> UserRule a -> [(Double,(Ver,Maybe String,b))]         f v p (UserRule x) = [(fromMaybe 1 p, (v,disp x,x2)) | Just x2 <- [test x]]@@ -98,8 +94,8 @@ getUserRuleMaybe key disp test = do     (_, xs, err) <- getUserRuleInternal key disp test     case xs of-        [] -> return Nothing-        [x] -> return $ Just x+        [] -> pure Nothing+        [x] -> pure $ Just x         _ -> throwM err  -- | A version of 'getUserRuleList' that fails if there is not exactly one result@@ -108,7 +104,7 @@ getUserRuleOne key disp test = do     (_, xs, err) <- getUserRuleInternal key disp test     case xs of-        [x] -> return x+        [x] -> pure x         _ -> throwM err  @@ -116,11 +112,7 @@ --   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 ListBuilder)) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)-    deriving (Functor, Applicative, Monad, MonadIO, MonadFix-#if __GLASGOW_HASKELL__ >= 800-             ,MonadFail-#endif-        )+    deriving (Functor, Applicative, Monad, MonadIO, MonadFix, Control.Monad.Fail.MonadFail)  newRules :: SRules ListBuilder -> Rules () newRules x = Rules $ liftIO . flip modifyIORef' (<> x) =<< asks snd@@ -133,14 +125,14 @@         res <- runReaderT r (opts, refNew)         rules <- readIORef refNew         modifyIORef' refOld (<> f rules)-        return res+        pure res  runRules :: ShakeOptions -> Rules () -> IO (SRules []) runRules opts (Rules r) = do     ref <- newIORef mempty     runReaderT r (opts, ref)     SRules{..} <- readIORef ref-    return $ SRules (runListBuilder actions) builtinRules userRules (runListBuilder targets) (runListBuilder helpSuffix)+    pure $ SRules (runListBuilder actions) builtinRules userRules (runListBuilder targets) (runListBuilder helpSuffix)  -- | Get all targets registered in the given rules. The names in --   'Development.Shake.phony' and 'Development.Shake.~>' as well as the file patterns@@ -150,12 +142,12 @@ getTargets :: ShakeOptions -> Rules () -> IO [(String, Maybe String)] getTargets opts rs = do     SRules{targets} <- runRules opts rs-    return [(target, documentation) | Target{..} <- targets]+    pure [(target, documentation) | Target{..} <- targets]  getHelpSuffix :: ShakeOptions -> Rules () -> IO [String] getHelpSuffix opts rs = do     SRules{helpSuffix} <- runRules opts rs-    return helpSuffix+    pure helpSuffix  data Target = Target     {target :: !String@@ -182,7 +174,7 @@     (<>) = liftA2 (<>)  instance (Semigroup a, Monoid a) => Monoid (Rules a) where-    mempty = return mempty+    mempty = pure mempty     mappend = (<>)  @@ -215,7 +207,7 @@  -- | A suitable 'BuiltinLint' that always succeeds. noLint :: BuiltinLint key value-noLint _ _ = return Nothing+noLint _ _ = pure Nothing  -- | A suitable 'BuiltinIdentity' that always fails with a runtime error, incompatible with 'shakeShare'. --   Use this function if you don't care about 'shakeShare', or if your rule provides a dependency that can@@ -239,7 +231,7 @@     => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules () addBuiltinRule = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp     (putEx . Bin.toLazyByteString . execPut . put)-    (runGet get . LBS.fromChunks . return)+    (runGet get . LBS.fromChunks . pure)  addBuiltinRuleEx     :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value, Partial)

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE ConstraintKinds, TupleSections, ViewPatterns #-} {-# LANGUAGE TypeFamilies, NamedFieldPuns #-}@@ -33,7 +34,7 @@ import qualified Data.HashSet as Set import Data.Dynamic import Data.Maybe-import Data.IORef+import Data.IORef.Extra import System.Directory import System.Time.Extra import qualified Data.ByteString as BS@@ -72,20 +73,20 @@  open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState open cleanup opts rs = withInit opts $ \opts@ShakeOptions{..} diagnostic _ -> do-    diagnostic $ return "Starting run"+    diagnostic $ pure "Starting run"     SRules{actions, builtinRules, userRules} <- runRules opts rs -    diagnostic $ return $ "Number of actions = " ++ show (length actions)-    diagnostic $ return $ "Number of builtin rules = " ++ show (Map.size builtinRules) ++ " " ++ show (Map.keys builtinRules)-    diagnostic $ return $ "Number of user rule types = " ++ show (TMap.size userRules)-    diagnostic $ return $ "Number of user rules = " ++ show (sum (TMap.toList (userRuleSize . userRuleContents) userRules))+    diagnostic $ pure $ "Number of actions = " ++ show (length actions)+    diagnostic $ pure $ "Number of builtin rules = " ++ show (Map.size builtinRules) ++ " " ++ show (Map.keys builtinRules)+    diagnostic $ pure $ "Number of user rule types = " ++ show (TMap.size userRules)+    diagnostic $ pure $ "Number of user rules = " ++ show (sum (TMap.toList (userRuleSize . userRuleContents) userRules))      checkShakeExtra shakeExtra     curdir <- getCurrentDirectory      database <- usingDatabase cleanup opts diagnostic builtinRules     (shared, cloud) <- loadSharedCloud database opts builtinRules-    return RunState{..}+    pure RunState{..}   -- Prepare for a fresh run by changing Result to Loaded@@ -145,11 +146,11 @@                 -- 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 >> getLocal) $ \x -> case x of+                    addPool PoolStart pool $ runAction global local (act >> getLocal) $ \case                         Left e -> raiseError =<< shakeException global stack e-                        Right local -> atomicModifyIORef locals $ \rest -> (local:rest, ())+                        Right local -> atomicModifyIORef_ locals (local:) -            maybe (return ()) (throwIO . snd) =<< readIORef except+            whenJustM (readIORef except) (throwIO . snd)             assertFinishedDatabase database             let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg @@ -172,7 +173,7 @@                     writeProfile file database             when (shakeLiveFiles /= []) $ do                 addTiming "Listing live"-                diagnostic $ return "Listing live keys"+                diagnostic $ pure "Listing live keys"                 xs <- liveFiles database                 forM_ shakeLiveFiles $ \file -> do                     putWhen Info $ "Writing live list to " ++ file@@ -180,21 +181,21 @@              res <- readIORef after             addTiming "Cleanup"-            return res+            pure res          whenJustM (readIORef timingsToShow) $             putStr . unlines-        return res+        pure 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'. shakeRunAfter :: ShakeOptions -> [IO ()] -> IO ()-shakeRunAfter _ [] = return ()+shakeRunAfter _ [] = pure () shakeRunAfter opts after = withInit opts $ \ShakeOptions{..} diagnostic _ -> do     let n = show $ length after-    diagnostic $ return $ "Running " ++ n ++ " after actions"+    diagnostic $ pure $ "Running " ++ n ++ " after actions"     (time, _) <- duration $ sequence_ $ reverse after     when (shakeTimings && shakeVerbosity >= Info) $         putStrLn $ "(+ running " ++ show n ++ " after actions in " ++ showDuration time ++ ")"@@ -210,17 +211,17 @@  usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions usingShakeOptions cleanup opts = do-    opts@ShakeOptions{..} <- if shakeThreads opts /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}+    opts@ShakeOptions{..} <- if shakeThreads opts /= 0 then pure opts else do p <- getProcessorCount; pure opts{shakeThreads=p}     when shakeLineBuffering $ usingLineBuffering cleanup     usingNumCapabilities cleanup shakeThreads-    return opts+    pure opts  outputFunctions :: ShakeOptions -> Lock -> (IO String -> IO (), Verbosity -> String -> IO ()) outputFunctions opts@ShakeOptions{..} outputLock = (diagnostic, output)     where         outputLocked v msg = withLock outputLock $ shakeOutput v msg -        diagnostic | shakeVerbosity < Diagnostic = const $ return ()+        diagnostic | shakeVerbosity < Diagnostic = const $ pure ()                    | otherwise = \act -> do v <- act; outputLocked Diagnostic $ "% " ++ v         output v = outputLocked v . shakeAbbreviationsApply opts @@ -230,9 +231,9 @@     let getProgress = do             failure <- getFailure             stats <- progress database step-            return stats{isFailure=failure}+            pure stats{isFailure=failure}     allocateThread cleanup $ shakeProgress getProgress-    return getProgress+    pure getProgress  checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO () checkShakeExtra mp = do@@ -241,12 +242,12 @@         (k,t):xs -> throwIO $ errorStructured "Invalid Map in shakeExtra"             [("Key",Just $ show k),("Value type",Just $ show t)]             (if null xs then "" else "Plus " ++ show (length xs) ++ " other keys")-        _ -> return ()+        _ -> pure ()   runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String) runLint mp k v = case Map.lookup (typeKey k) mp of-    Nothing -> return Nothing+    Nothing -> pure Nothing     Just BuiltinRule{..} -> builtinLint k v  @@ -269,27 +270,27 @@ liveFiles database = do     status <- getKeyValues database     let specialIsFileKey t = show (fst $ splitTyConApp t) == "FileQ"-    return [show k | (k, Ready{}) <- status, specialIsFileKey $ typeKey k]+    pure [show k | (k, Ready{}) <- status, specialIsFileKey $ typeKey k]  errorsState :: RunState -> IO [(String, SomeException)] errorsState RunState{..} = do     status <- getKeyValues database-    return [(show k, e) | (k, Failed e _) <- status]+    pure [(show k, e) | (k, Failed e _) <- status]   checkValid :: (IO String -> IO ()) -> Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO () checkValid diagnostic db check absent = do     status <- getKeyValues db-    diagnostic $ return "Starting validity/lint checking"+    diagnostic $ pure "Starting validity/lint checking"      -- TEST 1: Have values changed since being depended on     -- Do not use a forM here as you use too much stack space     bad <- (\f -> foldM f [] status) $ \seen v -> case v of         (key, Ready Result{..}) -> do             good <- check key $ fst result-            diagnostic $ return $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if isNothing good then "passed" else "FAILED"-            return $ [(key, result, now) | Just now <- [good]] ++ seen-        _ -> return seen+            diagnostic $ pure $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if isNothing good then "passed" else "FAILED"+            pure $ [(key, result, now) | Just now <- [good]] ++ seen+        _ -> pure seen     unless (null bad) $ do         let n = length bad         throwM $ errorStructured@@ -300,7 +301,7 @@      -- TEST 2: Is anything from lintTrackWrite which promised not to exist actually been created     exists <- getIdFromKey db-    bad <- return [(parent,key) | (parent, key) <- Set.toList $ Set.fromList absent, isJust $ exists key]+    bad <- pure [(parent,key) | (parent, key) <- Set.toList $ Set.fromList absent, isJust $ exists key]     unless (null bad) $ do         let n = length bad         throwM $ errorStructured@@ -308,7 +309,7 @@             (intercalate [("",Just "")] [ [("Rule", Just $ show parent), ("Created", Just $ show key)] | (parent,key) <- bad])             "" -    diagnostic $ return "Validity/lint check passed"+    diagnostic $ pure "Validity/lint check passed"   ---------------------------------------------------------------------@@ -318,11 +319,11 @@ usingDatabase cleanup opts diagnostic owitness = do     let step = (typeRep (Proxy :: Proxy StepKey), (Ver 0, BinaryOp (const mempty) (const stepKey)))     let root = (typeRep (Proxy :: Proxy Root), (Ver 0, BinaryOp (const mempty) (const rootKey)))-    witness <- return $ Map.fromList+    witness<- pure $ Map.fromList         [ (QTypeRep t, (version, BinaryOp (putDatabase putOp) (getDatabase getOp)))         | (t,(version, BinaryOp{..})) <- step : root : Map.toList (Map.map (\BuiltinRule{..} -> (builtinVersion, builtinKey)) owitness)]     (status, journal) <- usingStorage cleanup opts diagnostic witness-    journal <- return $ \i k v -> journal (QTypeRep $ typeKey k) i (k, v)+    journal<- pure $ \i k v -> journal (QTypeRep $ typeKey k) i (k, v)     createDatabase status journal Missing  @@ -330,13 +331,13 @@ incrementStep db = runLocked db $ do     stepId <- mkId db stepKey     v <- liftIO $ getKeyValueFromId db stepId-    step <- return $ case v of+    step<- pure $ case v of         Just (_, Loaded r) -> incStep $ fromStepResult r         _ -> Step 1     let stepRes = toStepResult step     setMem db stepId stepKey $ Ready stepRes     liftIO $ setDisk db stepId stepKey $ Loaded $ fmap snd stepRes-    return step+    pure step  toStepResult :: Step -> Result (Value, BS_Store) toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] 0 []@@ -369,13 +370,13 @@     let ver = makeVer $ shakeVersion opts      shared <- case shakeShare opts of-        Nothing -> return Nothing+        Nothing -> pure Nothing         Just x -> Just <$> newShared (shakeSymlink opts) wit2 ver x     cloud <- case newCloud (runLocked var) (Map.map builtinKey owitness) ver keyVers $ shakeCloud opts of-        _ | null $ shakeCloud opts -> return Nothing+        _ | null $ shakeCloud opts -> pure Nothing         Nothing -> fail "shakeCloud set but Shake not compiled for cloud operation"         Just res -> Just <$> res-    return (shared, cloud)+    pure (shared, cloud)   putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)

@@ -56,7 +56,7 @@ messageCorrupt :: FilePath -> SomeException -> IO [String] messageCorrupt dbfile err = do     msg <- showException err-    return $+    pure $         ("Error when reading Shake database " ++ dbfile) :         map ("  "++) (lines msg) ++         ["All files will be rebuilt"]@@ -97,15 +97,15 @@     -> Map.HashMap k (Ver, BinaryOp v)                 -- ^ Witnesses     -> IO (Ids.Ids v, k -> Id -> v -> IO ()) usingStorage _ ShakeOptions{..} diagnostic _ | shakeFiles == "/dev/null" = do-    diagnostic $ return "Using in-memory database"+    diagnostic $ pure "Using in-memory database"     ids <- Ids.empty-    return (ids, \_ _ _ -> return ())+    pure (ids, \_ _ _ -> pure ())  usingStorage cleanup ShakeOptions{..} diagnostic witness = do     let lockFile = shakeFiles </> ".shake.lock"-    diagnostic $ return $ "Before usingLockFile on " ++ lockFile+    diagnostic $ pure $ "Before usingLockFile on " ++ lockFile     usingLockFile cleanup lockFile-    diagnostic $ return "After usingLockFile"+    diagnostic $ pure "After usingLockFile"      let dbfile = shakeFiles </> ".shake.database"     createDirectoryRecursive shakeFiles@@ -113,7 +113,7 @@     -- complete a partially failed compress     whenM (restoreChunksBackup dbfile) $ do         unexpected "Backup file exists, restoring over the previous file\n"-        diagnostic $ return "Backup file move to original"+        diagnostic $ pure "Backup file move to original"      addTiming "Database read"     h <- usingChunks cleanup dbfile shakeFlush@@ -137,11 +137,11 @@     ids <- case witnessOld of         Left _ -> do             resetChunksCorrupt Nothing h-            return Nothing+            pure Nothing         Right witnessOld ->  handleBool (not . isAsyncException) (\err -> do             outputErr =<< messageCorrupt dbfile err             corrupt-            return Nothing) $ do+            pure Nothing) $ do              (!missing, !load) <- evaluate $ loadWitness witness witnessOld             when (missing /= []) $ outputErr $ messageMissingTypes dbfile missing@@ -154,8 +154,8 @@                         Left e -> do                             let slop = fromIntegral $ BS.length e                             when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"-                            diagnostic $ return $ "Read " ++ show i ++ " chunks, plus " ++ show slop ++ " slop"-                            return i+                            diagnostic $ pure $ "Read " ++ show i ++ " chunks, plus " ++ show slop ++ " slop"+                            pure i                         Right bs | (id, Just (k,v)) <- load bs -> do                             evaluate $ rnf k                             evaluate $ rnf v@@ -164,14 +164,14 @@                                 let pretty (Left x) = "FAILURE: " ++ show x                                     pretty (Right x) = x                                 x2 <- try_ $ evaluate $ let s = show v in rnf s `seq` s-                                return $ "Chunk " ++ show i ++ " " ++ raw bs ++ " " ++ show id ++ " = " ++ pretty x2+                                pure $ "Chunk " ++ show i ++ " " ++ raw bs ++ " " ++ show id ++ " = " ++ pretty x2                             go $ i+1                         Right bs -> do-                            diagnostic $ return $ "Chunk " ++ show i ++ " " ++ raw bs ++ " UNKNOWN WITNESS"+                            diagnostic $ pure $ "Chunk " ++ show i ++ " " ++ raw bs ++ " UNKNOWN WITNESS"                             go i             countItems <- go 0             countDistinct <- Ids.sizeUpperBound ids-            diagnostic $ return $ "Found at most " ++ show countDistinct ++ " distinct entries out of " ++ show countItems+            diagnostic $ pure $ "Found at most " ++ show countDistinct ++ " distinct entries out of " ++ show countItems              when (countItems > countDistinct*2 || not verEq || witnessOld /= witnessNew) $ do                 addTiming "Database compression"@@ -182,7 +182,7 @@             Just <$> Ids.forCopy ids snd      ids <- case ids of-        Just ids -> return ids+        Just ids -> pure ids         Nothing -> do             writeChunk h $ putEx ver             writeChunk h $ putEx witnessNew@@ -190,7 +190,7 @@      addTiming "With database"     out <- usingWriteChunks cleanup h-    return (ids, \k i v -> out $ save k i v)+    pure (ids, \k i v -> out $ save k i v)     where         unexpected x = when shakeStorageLog $ do             t <- getCurrentTime

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} {-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-} @@ -47,11 +46,8 @@ import Development.Shake.Classes import Data.Semigroup import General.Cleanup-import Prelude--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail-#endif+import Prelude   ---------------------------------------------------------------------@@ -61,11 +57,7 @@ --   Action values are used by 'addUserRule' and 'action'. The 'Action' monad tracks the dependencies of a rule. --   To raise an exception call 'error', 'fail' or @'liftIO' . 'throwIO'@. newtype Action a = Action {fromAction :: RAW ([String],[Key]) [Value] Global Local a}-    deriving (Functor, Applicative, Monad, MonadIO, Typeable, Semigroup, Monoid-#if __GLASGOW_HASKELL__ >= 800-             ,MonadFail-#endif-        )+    deriving (Functor, Applicative, Monad, MonadIO, Typeable, Semigroup, Monoid, MonadFail)  runAction :: Global -> Local -> Action a -> Capture (Either SomeException a) runAction g l (Action x) = runRAW (fromAction . build) g l x@@ -73,7 +65,7 @@         -- first argument is a list of call stacks, since build only takes one we use the first         -- they are very probably all identical...         build :: [([String], [Key])] -> Action [[Value]]-        build [] = return []+        build [] = pure []         build ks@((callstack,_):_) = do             let kss = map snd ks             unconcat kss <$> globalBuild g callstack (concat kss)@@ -296,7 +288,7 @@ -- -- > run key oldStore mode = do -- >     ...--- >     return $ RunResult change newStore newValue+-- >     pure $ RunResult change newStore newValue -- --   Where you have: --

@@ -7,8 +7,7 @@  import Control.Exception.Extra import Control.Monad-import Data.Char-import Data.List+import Data.List.Extra import Data.Maybe import System.Directory import System.Exit@@ -42,7 +41,7 @@     dir <- if empty then getCurrentDirectory else do         home <- getHomeDirectory         dir <- getDirectoryContents home-        return $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)+        pure $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)      putStrLn "% The Shake demo uses an empty directory, OK to use:"     putStrLn $ "%     " ++ dir@@ -100,21 +99,21 @@ yesNo :: Bool -> IO Bool yesNo auto = do     putStr "% [Y/N] (then ENTER): "-    x <- if auto then putLine "y" else fmap (map toLower) getLine+    x <- if auto then putLine "y" else lower <$> getLine     if "y" `isPrefixOf` x then-        return True+        pure True      else if "n" `isPrefixOf` x then-        return False+        pure False      else         yesNo auto  putLine :: String -> IO String-putLine x = putStrLn x >> return x+putLine x = putStrLn x >> pure x   -- | Replace exceptions with 'False'. wrap :: IO Bool -> IO Bool-wrap act = act `catch_` const (return False)+wrap act = act `catch_` const (pure False)   -- | Require a condition to be true, or exit with a message.

@@ -54,7 +54,7 @@ getHashedShakeVersion :: [FilePath] -> IO String getHashedShakeVersion files = do     hashes <- mapM (fmap (hashWithSalt 0) . BS.readFile) files-    return $ "hash-" ++ show (hashWithSalt 0 hashes)+    pure $ "hash-" ++ show (hashWithSalt 0 hashes)   -- | Get an item from 'shakeExtra', using the requested type as the key. Fails@@ -70,13 +70,13 @@ lookupShakeExtra mp =     case Map.lookup want mp of         Just dyn-            | Just x <- fromDynamic dyn -> return $ Just x+            | Just x <- fromDynamic dyn -> pure $ Just x             | otherwise -> throwM $ errorStructured                 "shakeExtra value is malformed, all keys and values must agree"                 [("Key", Just $ show want)                 ,("Value", Just $ show $ dynTypeRep dyn)]                 "Use addShakeExtra to ensure shakeExtra is well-formed"-        Nothing -> return Nothing+        Nothing -> pure Nothing     where want = typeRep (Proxy :: Proxy a)  -- | Add a properly structued value to 'shakeExtra' which can be retrieved with 'getShakeExtra'.@@ -145,7 +145,7 @@         -- semantics on Windows         b <- withFile name ReadMode $ \h -> do             src <- hGetContents h-            return $! src /= x+            pure $! src /= x         when b $ do             removeFile_ name -- symlink safety             writeFile name x@@ -252,7 +252,7 @@ -- @ -- google <- 'Development.Shake.newThrottle' \"Google\" 1 5 -- \"*.url\" 'Development.Shake.%>' \\out -> do---     'Development.Shake.withResource' google 1 $ return ()+--     'Development.Shake.withResource' google 1 $ pure () --     'Development.Shake.cmd' \"wget\" [\"https:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out] -- @ --@@ -290,7 +290,7 @@ -- @ -- digits \<- 'newCache' $ \\file -> do --     src \<- readFile\' file---     return $ length $ filter isDigit src+--     pure $ length $ filter isDigit src -- \"*.digits\" 'Development.Shake.%>' \\x -> do --     v1 \<- digits ('dropExtension' x) --     v2 \<- digits ('dropExtension' x)

@@ -6,12 +6,21 @@     getFileHash, getFileInfo     ) where +#ifndef MIN_VERSION_unix+#define MIN_VERSION_unix(a,b,c) 0+#endif++#ifndef MIN_VERSION_time+#define MIN_VERSION_time(a,b,c) 0+#endif++ import Data.Hashable import Control.Exception.Extra import Development.Shake.Classes import Development.Shake.Internal.FileName import qualified Data.ByteString.Lazy.Internal as LBS (defaultChunkSize)-import Data.Char+import Data.List.Extra import Data.Word import Numeric import System.IO@@ -27,8 +36,15 @@ import Control.Monad import qualified Data.ByteString.Char8 as BS import Foreign.C.String+import Data.Char  #else++#if MIN_VERSION_time(1,9,1)+import Data.Time.Clock+import Data.Fixed+#endif+ import Development.Shake.Internal.Errors import GHC.IO.Exception import System.IO.Error@@ -52,7 +68,7 @@     show (FileInfo x)         | x == 0 = "EQ"         | x == 1 = "NEQ"-        | otherwise = "0x" ++ map toUpper (showHex (x-2) "")+        | otherwise = "0x" ++ upper (showHex (x-2) "")  instance Eq (FileInfo a) where     FileInfo a == FileInfo b@@ -73,7 +89,7 @@         go h ptr salt = do             n <- hGetBufSome h ptr LBS.defaultChunkSize             if n == 0 then-                return $! fileInfo $ fromIntegral salt+                pure $! fileInfo $ fromIntegral salt             else                 go h ptr =<< hashPtrWithSalt ptr n salt @@ -87,14 +103,15 @@ result x y = do     x <- evaluate $ fileInfo x     y <- evaluate $ fileInfo y-    return $ Just (x, y)+    pure $ Just (x, y)  -getFileInfo :: FileName -> IO (Maybe (ModTime, FileSize))+-- | True = allow directory, False = disallow+getFileInfo :: Bool -> FileName -> IO (Maybe (ModTime, FileSize))  #if defined(PORTABLE) -- Portable fallback-getFileInfo x = handleBool isDoesNotExistError (const $ return Nothing) $ do+getFileInfo allowDir x = handleBool isDoesNotExistError (const $ pure Nothing) $ do     let file = fileNameToString x     time <- getModificationTime file     size <- withFile file ReadMode hFileSize@@ -106,12 +123,12 @@  #elif defined(mingw32_HOST_OS) -- Directly against the Win32 API, twice as fast as the portable version-getFileInfo x = BS.useAsCString (fileNameToByteString x) $ \file ->+getFileInfo allowDir x = BS.useAsCString (fileNameToByteString x) $ \file ->     alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do         res <- c_GetFileAttributesExA file 0 fad         let peek = do                 code <- peekFileAttributes fad-                if testBit code 4 then+                if not allowDir && testBit code 4 then                     throwIO $ errorDirectoryNotFile $ fileNameToString x                  else                     join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad)@@ -119,9 +136,9 @@             peek          else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do             res <- c_GetFileAttributesExW file 0 fad-            if res then peek else return Nothing+            if res then peek else pure Nothing          else-            return Nothing+            pure Nothing  #ifdef x86_64_HOST_ARCH #define CALLCONV ccall@@ -153,9 +170,9 @@  #else -- Unix version-getFileInfo x = handleBool isDoesNotExistError' (const $ return Nothing) $ do+getFileInfo allowDir x = handleBool isDoesNotExistError' (const $ pure Nothing) $ do     s <- getFileStatus $ fileNameToByteString x-    if isDirectory s then+    if not allowDir && isDirectory s then         throwM $ errorDirectoryNotFile $ fileNameToString x      else         result (extractFileTime s) (fromIntegral $ fileSize s)@@ -164,11 +181,12 @@             isDoesNotExistError e || ioeGetErrorType e == InappropriateType  extractFileTime :: FileStatus -> Word32-#ifndef MIN_VERSION_unix-#define MIN_VERSION_unix(a,b,c) 0-#endif #if MIN_VERSION_unix(2,6,0)-extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4 -- precision of 0.1ms+#if MIN_VERSION_time(1,9,1)+extractFileTime = fromInteger . (\(MkFixed x) -> x) . nominalDiffTimeToSeconds . modificationTimeHiRes+#else+extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4+#endif #else extractFileTime x = fromIntegral $ fromEnum $ modificationTime x #endif

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-}  module Development.Shake.Internal.FilePattern(@@ -84,7 +85,7 @@     where         -- str = I have ever seen a Str go past (equivalent to "can I be satisfied by no paths")         -- slash = I am either at the start, or my previous character was Slash-        f str slash = \x -> case x of+        f str slash = \case             [] -> [Lit "" | slash]             Str "**":xs -> Skip : f True False xs             Str x:xs -> parseLit x : f True False xs

@@ -36,13 +36,13 @@     forkFinally (timeout maxTime act) $ \res -> relock $ signalFence fence $ case res of         Right (Just v) -> v         _ -> def-    return fence+    pure fence  laterFence :: MonadIO m => Fence m a -> Wait m a laterFence fence = do     res <- liftIO $ testFence fence     case res of-        Just v -> return v+        Just v -> pure v         Nothing -> Later $ waitFence fence  @@ -52,8 +52,8 @@     server <- newServer conn binop globalVer     fence <- newLaterFence relock 10 Map.empty $ do         xs <- serverAllKeys server ruleVer-        return $ Map.fromList [(k,(v,ds,test)) | (k,v,ds,test) <- xs]-    return $ Cloud server relock fence+        pure $ Map.fromList [(k,(v,ds,test)) | (k,v,ds,test) <- xs]+    pure $ Cloud server relock fence   addCloud :: Cloud -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()@@ -63,7 +63,7 @@ lookupCloud :: Cloud -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ())) lookupCloud (Cloud server relock initial) ask key builtinVer userVer = runMaybeT $ do     mp <- lift $ laterFence initial-    Just (ver, deps, bloom) <- return $ Map.lookup key mp+    Just (ver, deps, bloom)<- pure $ Map.lookup key mp     unless (ver == userVer) $ fail ""     Right vs <- lift $ firstLeftWaitUnordered (fmap (maybeToEither ()) . ask) deps     unless (bloomTest bloom vs) $ fail ""@@ -72,8 +72,8 @@     f [deps] tree     where         f :: [[Key]] -> BuildTree Key -> MaybeT (Wait Locked) (BS_Store, [[Key]], IO ())-        f ks (Done store xs) = return (store, reverse ks, serverDownloadFiles server key xs)+        f ks (Done store xs) = pure (store, reverse ks, serverDownloadFiles server key xs)         f ks (Depend deps trees) = do             Right vs <- lift $ firstLeftWaitUnordered (fmap (maybeToEither ()) . ask) deps-            Just tree <- return $ lookup vs trees+            Just tree<- pure $ lookup vs trees             f (deps:ks) tree

@@ -28,7 +28,7 @@  #else -connect x = Just $ return $ Conn $ x ++ ['/' | not $ "/" `isSuffixOf` x]+connect x = Just $ pure $ Conn $ x ++ ['/' | not $ "/" `isSuffixOf` x]  post (Conn prefix) url send = do     let request = Request@@ -40,7 +40,7 @@     case response of         Left e -> fail $ "Network.post, failed: " ++ show e         Right v | rspCode v /= (2,0,0) -> fail $ "Network.post, failed: " ++ show (rspCode v)-                | otherwise -> return $ rspBody v+                | otherwise -> pure $ rspBody v   parseURI_ :: String -> URI

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances, DeriveTraversable #-}  -- | The endpoints on the cloud server module Development.Shake.Internal.History.Serialise(

@@ -24,16 +24,16 @@ data Server = Server Conn (Map.HashMap TypeRep (BinaryOp Key)) Ver  newServer :: Conn -> Map.HashMap TypeRep (BinaryOp Key) -> Ver -> IO Server-newServer a b c = return $ Server a b c+newServer a b c = pure $ Server a b c  serverAllKeys :: Server -> [(TypeRep, Ver)] -> IO [(Key, Ver, [Key], Bloom [BS_Identity])] serverAllKeys (Server conn key ver) typs = do     res <- post conn "allkeys/v1" $ LBS.fromChunks [runBuilder $ putEx $ withTypeReps $ SendAllKeys ver typs]     let RecvAllKeys ans = withoutKeys key $ getEx $ BS.concat $ LBS.toChunks res-    return ans+    pure ans  serverOneKey :: Server -> Key -> Ver -> Ver -> [(Key, BS_Identity)] -> IO (BuildTree Key)-serverOneKey _ _ _ _ _ = return $ Depend [] []+serverOneKey _ _ _ _ _ = pure $ Depend [] []   serverDownloadFiles :: Server -> Key -> [(FilePath, FileSize, FileHash)] -> IO ()

@@ -39,7 +39,7 @@     }  newShared :: Bool -> BinaryOp Key -> Ver -> FilePath -> IO Shared-newShared useSymlink keyOp globalVersion sharedRoot = return Shared{..}+newShared useSymlink keyOp globalVersion sharedRoot = pure Shared{..}   data Entry = Entry@@ -94,7 +94,7 @@ sharedFileKeys :: FilePath -> IO [FilePath] sharedFileKeys dir = do     b <- doesDirectoryExist_ $ dir </> "_key"-    if not b then return [] else listFiles $ dir </> "_key"+    if not b then pure [] else listFiles $ dir </> "_key"  loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [IO (Maybe Entry)] loadSharedEntry shared@Shared{..} key builtinVersion userVersion =@@ -103,7 +103,7 @@         f file = do             e@Entry{..} <- getEntry keyOp <$> BS.readFile file             let valid = entryKey == key && entryGlobalVersion == globalVersion && entryBuiltinVersion == builtinVersion && entryUserVersion == userVersion-            return $ if valid then Just e else Nothing+            pure $ if valid then Just e else Nothing   -- | Given a way to get the identity, see if you can find a stored cloud version@@ -113,7 +113,7 @@     flip firstJustWaitUnordered ents $ \act -> do         me <- liftIO act         case me of-            Nothing -> return Nothing+            Nothing -> pure Nothing             Just Entry{..} -> do                 -- 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@@ -151,10 +151,10 @@     deleted <- forM dirs $ \dir -> do         files <- sharedFileKeys dir         -- if any key matches, clean them all out-        b <- flip anyM files $ \file -> handleSynchronous (\e -> putStrLn ("Warning: " ++ show e) >> return False) $+        b <- flip anyM files $ \file -> handleSynchronous (\e -> putStrLn ("Warning: " ++ show e) >> pure False) $             evaluate . test . entryKey . getEntry keyOp =<< BS.readFile file         when b $ removePathForcibly dir-        return b+        pure b     liftIO $ putStrLn $ "Deleted " ++ show (length (filter id deleted)) ++ " entries"  listShared :: Shared -> IO ()

@@ -32,11 +32,11 @@  createLinkMaybe from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do     res <- c_CreateHardLinkW cto cfrom nullPtr-    return $ if res then Nothing else Just "CreateHardLink failed."+    pure $ if res then Nothing else Just "CreateHardLink failed."  #else -createLinkMaybe from to = handleIO (return . Just . show) $ createLink from to >> return Nothing+createLinkMaybe from to = handleIO (pure . Just . show) $ createLink from to >> pure Nothing  #endif 

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}  -- | Types exposed to the user module Development.Shake.Internal.Options(@@ -210,6 +210,9 @@         --   If this setting is @True@ (even if symlinks are not available) then files will be         --   made read-only to avoid inadvertantly poisoning the shared cache.         --   Note the links are actually hard links, not symlinks.+    ,shakeNeedDirectory :: Bool+        -- ^ Defaults to @False@. Is depending on a directory an error (default), or it is permitted with+        --   undefined results. Provided for compatibility with @ninja@.     ,shakeProgress :: IO Progress -> IO ()         -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported.         --   The function is called on a separate thread, and that thread is killed when the build completes.@@ -234,10 +237,10 @@ shakeOptions :: ShakeOptions shakeOptions = ShakeOptions     ".shake" 1 "1" Info False [] Nothing [] [] [] [] (Just 10) [] [] False True False-    True ChangeModtime True [] False False Nothing [] False-    (const $ return ())+    True ChangeModtime True [] False False Nothing [] False False+    (const $ pure ())     (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS-    (\_ _ _ -> return ())+    (\_ _ _ -> pure ())     Map.empty  fieldsShakeOptions =@@ -246,19 +249,20 @@     ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog"     ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"     ,"shakeLiveFiles", "shakeVersionIgnore", "shakeColor", "shakeShare", "shakeCloud", "shakeSymlink"+    ,"shakeNeedDirectory"     ,"shakeProgress", "shakeOutput", "shakeTrace", "shakeExtra"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 y1 y2 y3 y4 =-    ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 y1 y2 y3 y4 =+    ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27         (fromHidden y1) (fromHidden y2) (fromHidden y3) (fromHidden y4)  instance Data ShakeOptions where-    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 y1 y2 y3 y4) =+    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 y1 y2 y3 y4) =         z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k`-        x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k` x26 `k`+        x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k` x26 `k` x27 `k`         Hidden y1 `k` Hidden y2 `k` Hidden y3 `k` Hidden y4-    gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+    gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide     toConstr ShakeOptions{} = conShakeOptions     dataTypeOf _ = tyShakeOptions 

@@ -36,7 +36,7 @@ #ifdef FILE_EMBED  initDataDirectory :: IO ()-initDataDirectory = return ()+initDataDirectory = pure ()  htmlDataFiles :: [(FilePath, BS.ByteString)] htmlDataFiles =@@ -49,13 +49,13 @@ readDataFileHTML file = do     case lookup file htmlDataFiles of       Nothing -> fail $ "Could not find data file " ++ file ++ " in embedded data files!"-      Just x  -> return (LBS.fromStrict x)+      Just x  -> pure (LBS.fromStrict x)  manualDirData :: [(FilePath, BS.ByteString)] manualDirData = $(embedDir "docs/manual")  hasManualData :: IO Bool-hasManualData = return True+hasManualData = pure True  copyManualData :: FilePath -> IO () copyManualData dest = do@@ -70,9 +70,9 @@ dataDirs :: [String] dataDirs = unsafePerformIO $ do     datdir <- getDataDir-    exedir <- takeDirectory <$> getExecutablePath `catchIO` \_ -> return ""+    exedir <- takeDirectory <$> getExecutablePath `catchIO` \_ -> pure ""     curdir <- getCurrentDirectory-    return $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir]+    pure $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir]  -- The data files may be located relative to the current directory, if so cache it in advance initDataDirectory :: IO ()@@ -84,7 +84,7 @@     res <- filterM doesFileExist_ poss     case res of         [] -> fail $ unlines $ ("Could not find data file " ++ file ++ ", looked in:") : map ("  " ++) poss-        x:_ -> return x+        x:_ -> pure x  hasDataFile :: FilePath -> IO Bool hasDataFile file = anyM (\dir -> doesFileExist_ $ dir </> file) dataDirs

@@ -85,7 +85,7 @@             }             where fromStep i = fromJust $ Map.lookup i steps                   fromTrace (Trace a b c) = ProfileTrace (BS.unpack a) (floatToDouble b) (floatToDouble c)-    return [maybe (throwImpure $ errorInternal "toReport") f $ Map.lookup i status | i <- order]+    pure [maybe (throwImpure $ errorInternal "toReport") f $ Map.lookup i status | i <- order]   data ProfileEntry = ProfileEntry@@ -131,7 +131,7 @@ generateHTML :: [ProfileEntry] -> IO LBS.ByteString generateHTML xs = do     report <- readDataFileHTML "profile.html"-    let f "data/profile-data.js" = return $ LBS.pack $ "var profile =\n" ++ generateJSON xs+    let f "data/profile-data.js" = pure $ LBS.pack $ "var profile =\n" ++ generateJSON xs     runTemplate f report  

@@ -53,7 +53,7 @@ progress :: Database -> Step -> IO Progress progress db step = do     xs <- getKeyValues db-    return $! foldl' f mempty $ map snd xs+    pure $! foldl' f mempty $ map snd xs     where         g = floatToDouble @@ -217,7 +217,7 @@             sleep sample             p <- prog             t <- time-            ((secs,perc,_debug), mealy) <- return $ runMealy mealy (t, p)+            ((secs,perc,_debug), mealy)<- pure $ runMealy mealy (t, p)             -- putStrLn _debug             let done = countSkipped p + countBuilt p             let todo = done + countUnknown p + countTodo p@@ -270,7 +270,7 @@ generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString generateHTML xs = do     report <- readDataFileHTML "progress.html"-    let f "data/progress-data.js" = return $ LBS.pack $ "var progress =\n" ++ generateJSON xs+    let f "data/progress-data.js" = pure $ LBS.pack $ "var progress =\n" ++ generateJSON xs     runTemplate f report  generateJSON :: [(FilePath, [ProgressEntry])] -> String@@ -299,7 +299,7 @@ #ifdef mingw32_HOST_OS         win = withCWString x c_setConsoleTitleW #else-        win = return False+        win = pure False #endif          lin = whenM checkEscCodes $ BS.putStr $ BS.pack $ escWindowTitle x@@ -323,10 +323,10 @@ progressProgram = do     exe <- findExecutable "shake-progress"     case exe of-        Nothing -> return $ const $ return ()+        Nothing -> pure $ const $ pure ()         Just exe -> do             lastArgs <- newIORef Nothing -- the arguments we passed to shake-progress last time-            return $ \msg -> do+            pure $ \msg -> do                 let failure = " Failure! " `isInfixOf` msg                 let perc = let (a,b) = break (== '%') msg                            in if null b then "" else reverse $ takeWhile isDigit $ reverse a

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards, ViewPatterns #-}  module Development.Shake.Internal.Resource(@@ -26,7 +27,7 @@ resourceId :: IO Int resourceId = unsafePerformIO $ do     ref <- newIORef 0-    return $ atomicModifyIORef' ref $ \i -> let j = i + 1 in (j, j)+    pure $ atomicModifyIORef' ref $ \i -> let j = i + 1 in (j, j)   -- | Run an action which uses part of a finite resource. For more details see 'Resource'.@@ -34,17 +35,17 @@ withResource :: Resource -> Int -> Action a -> Action a withResource r i act = do     Global{..} <- Action getRO-    liftIO $ globalDiagnostic $ return $ show r ++ " waiting to acquire " ++ show i+    liftIO $ globalDiagnostic $ pure $ show r ++ " waiting to acquire " ++ show i      fence <- liftIO $ acquireResource r globalPool i     whenJust fence $ \fence -> do         (offset, ()) <- actionFenceRequeueBy Right fence         Action $ modifyRW $ addDiscount offset -    liftIO $ globalDiagnostic $ return $ show r ++ " running with " ++ show i+    liftIO $ globalDiagnostic $ pure $ show r ++ " running with " ++ show i     Action $ fromAction (blockApply ("Within withResource using " ++ show r) act) `finallyRAW` do         liftIO $ releaseResource r globalPool i-        liftIO $ globalDiagnostic $ return $ show r ++ " released " ++ show i+        liftIO $ globalDiagnostic $ pure $ show r ++ " released " ++ show i   @@ -98,7 +99,7 @@         errorIO $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx     key <- resourceId     var <- newVar $ Finite mx mempty-    return $ Resource (negate key) shw (acquire var) (release var)+    pure $ Resource (negate key) shw (acquire var) (release var)     where         shw = "Resource " ++ name @@ -108,18 +109,18 @@             | want > mx = errorIO $ "You cannot acquire more than " ++ show mx ++ " of " ++ shw ++ ", requested " ++ show want             | otherwise = modifyVar var $ \x@Finite{..} ->                 if want <= finiteAvailable then-                    return (x{finiteAvailable = finiteAvailable - want}, Nothing)+                    pure (x{finiteAvailable = finiteAvailable - want}, Nothing)                 else do                     fence <- newFence-                    return (x{finiteWaiting = finiteWaiting `snoc` (want, fence)}, Just fence)+                    pure (x{finiteWaiting = finiteWaiting `snoc` (want, fence)}, Just fence)          release :: Var Finite -> Pool -> Int -> IO ()-        release var _ i = join $ modifyVar var $ \x -> return $ f x{finiteAvailable = finiteAvailable x + i}+        release var _ i = join $ modifyVar var $ \x -> pure $ f x{finiteAvailable = finiteAvailable x + i}             where                 f (Finite i (uncons -> Just ((wi,wa),ws)))                     | wi <= i = second (signalFence wa () >>) $ f $ Finite (i-wi) ws                     | otherwise = first (add (wi,wa)) $ f $ Finite i ws-                f (Finite i _) = (Finite i mempty, return ())+                f (Finite i _) = (Finite i mempty, pure ())                 add a s = s{finiteWaiting = a `cons` finiteWaiting s}  @@ -149,7 +150,7 @@         errorIO $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count     key <- resourceId     var <- newVar $ ThrottleAvailable count-    return $ Resource key shw (acquire var) (release var)+    pure $ Resource key shw (acquire var) (release var)     where         shw = "Throttle " ++ name @@ -157,23 +158,23 @@         acquire var pool want             | want < 0 = errorIO $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want             | want > count = errorIO $ "You cannot acquire more than " ++ show count ++ " of " ++ shw ++ ", requested " ++ show want-            | otherwise = modifyVar var $ \x -> case x of+            | otherwise = modifyVar var $ \case                 ThrottleAvailable i-                    | i >= want -> return (ThrottleAvailable $ i - want, Nothing)+                    | i >= want -> pure (ThrottleAvailable $ i - want, Nothing)                     | otherwise -> do                         stop <- keepAlivePool pool                         fence <- newFence-                        return (ThrottleWaiting stop $ (want - i, fence) `cons` mempty, Just fence)+                        pure (ThrottleWaiting stop $ (want - i, fence) `cons` mempty, Just fence)                 ThrottleWaiting stop xs -> do                     fence <- newFence-                    return (ThrottleWaiting stop $ xs `snoc` (want, fence), Just fence)+                    pure (ThrottleWaiting stop $ xs `snoc` (want, fence), Just fence)          release :: Var Throttle -> Pool -> Int -> IO ()-        release var _ n = waiter period $ join $ modifyVar var $ \x -> return $ case x of-                ThrottleAvailable i -> (ThrottleAvailable $ i+n, return ())+        release var _ n = waiter period $ join $ modifyVar var $ \x -> pure $ case x of+                ThrottleAvailable i -> (ThrottleAvailable $ i+n, pure ())                 ThrottleWaiting stop xs -> f stop n xs             where                 f stop i (uncons -> Just ((wi,wa),ws))                     | i >= wi = second (signalFence wa () >>) $ f stop (i-wi) ws-                    | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, return ())+                    | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, pure ())                 f stop i _ = (ThrottleAvailable i, stop)

@@ -121,12 +121,12 @@ queryRule witness query = addBuiltinRuleEx     (\k old -> do         new <- query k-        return $ if old == new then Nothing else Just $ show new)+        pure $ if old == new then Nothing else Just $ show new)     (\_ v -> Just $ runBuilder $ putEx $ witness v)     (\k old _ -> liftIO $ do         new <- query k         let wnew = witness new-        return $ case old of+        pure $ case old of             Just old | wnew == getEx old -> RunResult ChangedNothing old new             _ -> RunResult ChangedRecomputeDiff (runBuilder $ putEx wnew) new) @@ -276,7 +276,7 @@         f dir (WalkTo (files, dirs)) = do             files <- filterM (IO.doesFileExist . (root </>)) $ map (dir </>) files             dirs <- concatMapM (uncurry f) =<< filterM (IO.doesDirectoryExist . (root </>) . fst) (map (first (dir </>)) dirs)-            return $ files ++ dirs+            pure $ files ++ dirs   ---------------------------------------------------------------------

@@ -146,14 +146,14 @@       deriving (Eq,Ord,Show,Read,Typeable,Enum,Bounded)  fileStoredValue :: ShakeOptions -> FileQ -> IO (Maybe FileA)-fileStoredValue ShakeOptions{shakeChange=c} (FileQ x) = do-    res <- getFileInfo x+fileStoredValue ShakeOptions{shakeChange=c, shakeNeedDirectory=allowDir} (FileQ x) = do+    res <- getFileInfo allowDir x     case res of-        Nothing -> return Nothing-        Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size noFileHash+        Nothing -> pure Nothing+        Just (time,size) | c == ChangeModtime -> pure $ Just $ FileA time size noFileHash         Just (time,size) -> do             hash <- unsafeInterleaveIO $ getFileHash x-            return $ Just $ FileA time size hash+            pure $ Just $ FileA time size hash   fileEqualValue :: ShakeOptions -> FileA -> FileA -> EqualCost@@ -173,7 +173,7 @@ storedValueError opts False msg x | False && not (shakeOutputCheck opts) = do     when (shakeCreationCheck opts) $ do         whenM (isNothing <$> (storedValue opts x :: IO (Maybe FileA))) $ error $ msg ++ "\n  " ++ unpackU (fromFileQ x)-    return $ FileA fileInfoEq fileInfoEq fileInfoEq+    pure $ FileA fileInfoEq fileInfoEq fileInfoEq -} storedValueError opts input msg x = maybe def Just <$> fileStoredValue opts2 x     where def = if shakeCreationCheck opts || input then error err else Nothing@@ -193,11 +193,11 @@ ruleLint :: ShakeOptions -> BuiltinLint FileQ FileR ruleLint opts k (FileR (Just v) True) = do     now <- fileStoredValue opts k-    return $ case now of+    pure $ case now of         Nothing -> Just "<missing>"         Just now | fileEqualValue opts v now == EqualCheap -> Nothing                  | otherwise -> Just $ show now-ruleLint _ _ _ = return Nothing+ruleLint _ _ _ = pure Nothing  ruleIdentity :: ShakeOptions -> BuiltinIdentity FileQ FileR ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure errorNoHash@@ -268,10 +268,10 @@         unLint (RunResult a b c) = RunResult a b c{useLint = False}          retNew :: RunChanged -> Answer -> Action (RunResult FileR)-        retNew c v = return $ RunResult c (runBuilder $ putEx v) $ fileR v+        retNew c v = pure $ RunResult c (runBuilder $ putEx v) $ fileR v          retOld :: RunChanged -> Action (RunResult FileR)-        retOld c = return $ RunResult c (fromJust oldBin) $ fileR (fromJust old)+        retOld c = pure $ RunResult c (fromJust oldBin) $ fileR (fromJust old)          -- actually run the rebuild         rebuildWith act = do@@ -315,7 +315,7 @@                                     res <- answer (AnswerDirect $ Ver ver) new                                     historySave ver $ runBuilder $                                         if isNoFileHash fileHash then throwImpure errorNoHash else putExStorable fileHash-                                    return res+                                    pure res                 Just (_, ModePhony act) -> do                     -- See #523 and #524                     -- Shake runs the dependencies first, but stops when one has changed.@@ -338,16 +338,16 @@ resultHasChanged file = do     let filename = FileQ $ fileNameFromString file     res <- getDatabaseValue filename-    old <- return $ case result <$> res of+    old<- pure $ case result <$> res of         Nothing -> Nothing         Just (Left bs) -> fromAnswer $ getEx bs         Just (Right v) -> answer v     case old of-        Nothing -> return True+        Nothing -> pure True         Just old -> do             opts <- getShakeOptions             new <- liftIO $ fileStoredValue opts filename-            return $ case new of+            pure $ case new of                 Nothing -> True                 Just new -> fileEqualValue opts old new == NotEqual @@ -403,13 +403,13 @@     apply_ fileNameFromString paths     self <- getCurrentKey     selfVal <- case self of-        Nothing -> return Nothing+        Nothing -> pure Nothing         Just self -> getDatabaseValueGeneric self     case selfVal of-        Nothing -> return paths -- never build before or not a key, so everything has changed+        Nothing -> pure paths -- never build before or not a key, so everything has changed         Just selfVal -> flip filterM paths $ \path -> do             pathVal <- getDatabaseValue (FileQ $ fileNameFromString path)-            return $ case pathVal of+            pure $ case pathVal of                 Just pathVal | changed pathVal > built selfVal -> True                 _ -> False @@ -439,7 +439,7 @@     let bad = [ (x, if isJust a then "File change" else "File created")               | (x, a, FileR (Just b) _) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual]     case bad of-        [] -> return ()+        [] -> pure ()         (file,msg):_ -> throwM $ errorStructured             "Lint checking error - 'needed' file required rebuilding"             [("File", Just $ fileNameToString file)@@ -502,7 +502,7 @@ --   This function is defined in terms of 'action' and 'need', use 'action' if you need more complex --   targets than 'want' allows. want :: Partial => [FilePath] -> Rules ()-want [] = return ()+want [] = pure () want xs = withFrozenCallStack $ action $ need xs  @@ -574,7 +574,7 @@     mapM_ addTarget pats     let (simp,other) = partition simple pats     case map toStandard simp of-        [] -> return ()+        [] -> pure ()         [p] -> root help (\x -> toStandard x == p) act         ps -> let set = Set.fromList ps in root help (flip Set.member set . toStandard) act     unless (null other) $

@@ -73,10 +73,10 @@     addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts)  ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA-ruleLint _ _ (FilesA []) = return Nothing -- in the case of disabling lint+ruleLint _ _ (FilesA []) = pure Nothing -- in the case of disabling lint ruleLint opts k v = do     now <- filesStoredValue opts k-    return $ case now of+    pure $ case now of         Nothing -> Just "<missing>"         Just now | filesEqualValue opts v now == EqualCheap -> Nothing                  | otherwise -> Just $ show now@@ -107,20 +107,20 @@             Just _ ->                 -- ignoring the currently stored value, which may trigger lint has changed                 -- so disable lint on this file-                return $ RunResult ChangedNothing (fromJust o) $ FilesA []+                pure $ RunResult ChangedNothing (fromJust o) $ FilesA []             Nothing -> do                 -- i don't have a previous value, so assume this is a source node, and mark rebuild in future                 now <- liftIO $ filesStoredValue opts k                 case now of                     Nothing -> rebuild-                    Just now -> do alwaysRerun; return $ RunResult ChangedStore (runBuilder $ putEx $ Result (Ver 0) now) now+                    Just now -> do alwaysRerun; pure $ RunResult ChangedStore (runBuilder $ putEx $ Result (Ver 0) now) now         Just (Result ver old) | mode == RunDependenciesSame, verEq ver -> do             v <- liftIO $ filesStoredValue opts k             case v of                 Just v -> case filesEqualValue opts old v of                     NotEqual -> rebuild-                    EqualCheap -> return $ RunResult ChangedNothing (fromJust o) v-                    EqualExpensive -> return $ RunResult ChangedStore (runBuilder $ putEx $ Result ver v) v+                    EqualCheap -> pure $ RunResult ChangedNothing (fromJust o) v+                    EqualExpensive -> pure $ RunResult ChangedStore (runBuilder $ putEx $ Result ver v) v                 Nothing -> rebuild         _ -> rebuild     where@@ -130,16 +130,16 @@                 Just res ->                     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+                        pure $ FileA mod size $ getExStorable bin                 Nothing -> do                     FilesA v <- act                     producesUnchecked $ map (fileNameToString . fromFileQ) $ fromFilesQ k                     historySave ver $ runBuilder $ putExList                         [if isNoFileHash hash then throwImpure errorNoHash else putExStorable hash | FileA _ _ hash <- v]-                    return $ FilesA v+                    pure $ FilesA v             let c | Just (Result _ old) <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame                   | otherwise = ChangedRecomputeDiff-            return $ RunResult c (runBuilder $ putEx $ Result (Ver ver) v) v+            pure $ RunResult c (runBuilder $ putEx $ Result (Ver ver) v) v   @@ -159,7 +159,7 @@ --   have the same sequence of @\/\/@ and @*@ wildcards in the same order. --   This function will create directories for the result files, if necessary. (&%>) :: Located => [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-[p] &%> act = withFrozenCallStack $ p %> act . return+[p] &%> act = withFrozenCallStack $ p %> act . pure ps &%> act     | not $ compatible ps = error $ unlines $         "All patterns to &%> must have the same number and position of ** and * wildcards" :@@ -169,7 +169,7 @@             (if simple p then id else priority 0.5) $                 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+                    pure $ if null res then Nothing else Just $ res !! i         (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@@ -208,7 +208,7 @@     let checkedTest x = case normTest x of             Nothing -> Nothing             Just ys | x `notElem` ys -> error $ unlines $-                "Invariant broken in &?>, did not return the input (after normalisation)." :+                "Invariant broken in &?>, did not pure the input (after normalisation)." :                 inputOutput "" x ys             Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $                 ["Invariant broken in &?>, not equalValue for all arguments (after normalisation)."] ++@@ -220,7 +220,7 @@         Nothing -> Nothing         Just ys -> Just $ do             FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys-            return $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys)+            pure $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys)      addUserRule $ FilesRule ("&?> " ++ callStackTop) $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in         case checkedTest x of@@ -238,8 +238,8 @@     let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts     ys <- liftIO $ mapM (fileStoredValue opts2) xs     case sequence ys of-        Just ys -> return $ FilesA ys-        Nothing | not $ shakeCreationCheck opts -> return $ FilesA []+        Just ys -> pure $ FilesA ys+        Nothing | not $ shakeCreationCheck opts -> pure $ FilesA []         Nothing -> do             let missing = length $ filter isNothing ys             error $ "Error, " ++ name ++ " rule failed to produce " ++ show missing ++

@@ -41,28 +41,28 @@          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+                pure $ RunResult ChangedNothing old $ decode' old             _ -> do                 -- can only use cmpHash if flavor == Hash                 let cmpValue new = if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff                 let cmpHash newHash = if old == Just newHash then ChangedRecomputeSame else ChangedRecomputeDiff -                cache <- if flavor == Cache then historyLoad 0 else return Nothing+                cache <- if flavor == Cache then historyLoad 0 else pure Nothing                 case cache of                     Just newEncode -> do                         let new = decode' newEncode-                        return $ RunResult (cmpValue new) newEncode new+                        pure $ RunResult (cmpValue new) newEncode new                     Nothing -> do                         new <- OracleA <$> act q                         let newHash = encodeHash new                         let newEncode = encode' new                         when (flavor == Cache) $                             historySave 0 newEncode-                        return $+                        pure $                             if flavor == Hash                                 then RunResult (cmpHash newHash) newHash new                                 else RunResult (cmpValue new) newEncode new-        return askOracle+        pure askOracle     where         encodeHash :: Hashable a => a -> BS.ByteString         encodeHash = runBuilder . putEx . hash@@ -71,7 +71,7 @@         encode' = BS.concat . LBS.toChunks . encode          decode' :: Binary a => BS.ByteString -> a-        decode' = decode . LBS.fromChunks . return+        decode' = decode . LBS.fromChunks . pure   -- | Add extra information which rules can depend on.@@ -112,11 +112,11 @@ -- rules = do --     getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do --         Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"---         return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]+--         pure [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x] -- --     getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do --         pkgs <- getPkgList $ GhcPkgList ()---         return $ lookup pkg pkgs+--         pure $ lookup pkg pkgs -- --     \"myrule\" %> \\_ -> do --         getPkgVersion $ GhcPkgVersion \"shake\"

@@ -43,4 +43,4 @@ defaultRuleRerun :: Rules () defaultRuleRerun =     addBuiltinRuleEx noLint noIdentity $-        \AlwaysRerunQ{} _ _ -> return $ RunResult ChangedRecomputeDiff BS.empty ()+        \AlwaysRerunQ{} _ _ -> pure $ RunResult ChangedRecomputeDiff BS.empty ()

@@ -109,7 +109,7 @@ --   exercise our build system with: -- -- > example = do--- >     fileRule "a.txt" $ return ()+-- >     fileRule "a.txt" $ pure () -- >     fileRule "b.txt" $ do -- >         fileNeed "a.txt" -- >         liftIO $ writeFile "b.txt" . reverse =<< readFile "a.txt"@@ -122,18 +122,18 @@ -- > addBuiltinFileRule :: Rules () -- > addBuiltinFileRule = addBuiltinRule noLint noIdentity run -- >     where--- >         fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else return ""+-- >         fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else pure "" -- > -- >         run :: BuiltinRun File () -- >         run key old mode = do -- >             now <- liftIO $ fileContents key -- >             if mode == RunDependenciesSame && fmap BS.unpack old == Just now then--- >                 return $ RunResult ChangedNothing (BS.pack now) ()+-- >                 pure $ RunResult ChangedNothing (BS.pack now) () -- >             else do -- >                 (_, act) <- getUserRuleOne key (const Nothing) $ \(FileRule k act) -> if k == key then Just act else Nothing -- >                 act -- >                 now <- liftIO $ fileContents key--- >                 return $ RunResult ChangedRecomputeDiff (BS.pack now) ()+-- >                 pure $ RunResult ChangedRecomputeDiff (BS.pack now) () -- --   We define a wrapper @addBuiltinFileRule@ that calls @addBuiltinRule@, opting out of linting and cached storage. --   The only thing we provide is a 'BuiltinRun' function which gets the previous state, and whether any dependency has changed,

@@ -50,7 +50,7 @@ -- data Flags = Flags {distCC :: Bool} deriving Eq -- flags = [Option \"\" [\"distcc\"] (NoArg $ Right $ \\x -> x{distCC=True}) \"Run distributed.\"] ----- main = 'shakeArgsAccumulate' 'shakeOptions' flags (Flags False) $ \\flags targets -> return $ Just $ do+-- main = 'shakeArgsAccumulate' 'shakeOptions' flags (Flags False) $ \\flags targets -> pure $ Just $ do --     if null targets then 'want' [\"result.exe\"] else 'want' targets --     let compiler = if distCC flags then \"distcc\" else \"gcc\" --     \"*.o\" '%>' \\out -> do@@ -68,7 +68,7 @@ --   the second argument is called with a list of the files that the build checked were up-to-date. shakeArgsPrune :: ShakeOptions -> ([FilePath] -> IO ()) -> Rules () -> IO () shakeArgsPrune opts prune rules = shakeArgsPruneWith opts prune [] f-    where f _ files = return $ Just $ if null files then rules else want files >> withoutActions rules+    where f _ files = pure $ Just $ if null files then rules else want files >> withoutActions rules   -- | A version of 'shakeArgsPrune' that also takes a list of extra options to use.@@ -80,7 +80,7 @@         case sequence opts of             Nothing -> do                 writeIORef pruning True-                return Nothing+                pure Nothing             Just opts -> act opts args     whenM (readIORef pruning) $         IO.withTempFile $ \file -> do

@@ -79,7 +79,7 @@     (Builder x1 x2) <> (Builder y1 y2) = Builder (x1+y1) $ \p i -> do x2 p i; y2 p $ i+x1  instance Monoid Builder where-    mempty = Builder 0 $ \_ _ -> return ()+    mempty = Builder 0 $ \_ _ -> pure ()     mappend = (<>)  -- | Methods for Binary serialisation that go directly between strict ByteString values.@@ -97,13 +97,13 @@  instance BinaryEx LBS.ByteString where     putEx x = Builder (fromIntegral $ LBS.length x) $ \ptr i -> do-        let go _ [] = return ()+        let go _ [] = pure ()             go i (x:xs) = do                 let n = BS.length x                 BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)                 go (i+n) xs         go i $ LBS.toChunks x-    getEx = LBS.fromChunks . return+    getEx = LBS.fromChunks . pure  instance BinaryEx [BS.ByteString] where     -- Format:@@ -113,7 +113,7 @@     putEx xs = Builder (4 + (n * 4) + sum ns) $ \p i -> do         pokeByteOff p i (fromIntegral n :: Word32)         for2M_ [4+i,8+i..] ns $ \i x -> pokeByteOff p i (fromIntegral x :: Word32)-        p <- return $ p `plusPtr` (i + 4 + (n * 4))+        p<- pure $ p `plusPtr` (i + 4 + (n * 4))         for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.useAsCStringLen x $ \(bs, n) ->             BS.memcpy (p `plusPtr` i) (castPtr bs) (fromIntegral n)         where ns = map BS.length xs@@ -122,7 +122,7 @@     getEx bs = unsafePerformIO $ BS.useAsCString bs $ \p -> do         n <- fromIntegral <$> (peekByteOff p 0 :: IO Word32)         ns :: [Word32] <- forM [1..fromIntegral n] $ \i -> peekByteOff p (i * 4)-        return $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns+        pure $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns  instance BinaryEx () where     putEx () = mempty@@ -197,7 +197,7 @@ --     BS putExList :: [Builder] -> Builder putExList xs = Builder (sum $ map (\b -> sizeBuilder b + 4) xs) $ \p i -> do-    let go _ [] = return ()+    let go _ [] = pure ()         go i (Builder n b:xs) = do             pokeByteOff p i (fromIntegral n :: Word32)             b p (i+4)

@@ -44,12 +44,12 @@ readChunkDirect h mx = do     let slop x = do             unless (BS.null x) $ hSetFileSize h . subtract (toInteger $ BS.length x) =<< hFileSize h-            return $ Left x+            pure $ Left x     n <- BS.hGet h 4     if BS.length n < 4 then slop n else do         let count = fromIntegral $ min mx $ fst $ unsafeBinarySplit n         v <- BS.hGet h count-        if BS.length v < count then slop (n `BS.append` v) else return $ Right v+        if BS.length v < count then slop (n `BS.append` v) else pure $ Right v  writeChunkDirect :: Handle -> Builder -> IO () writeChunkDirect h x = bs `seq` BS.hPut h bs@@ -72,18 +72,18 @@             takeMVar kick             sleep flush             tryTakeMVar kick-            writeChan chan $ hFlush h >> return True+            writeChan chan $ hFlush h >> pure True      -- 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+    register cleanup $ writeChan chan $ pure False -    return $ \s -> do+    pure $ \s -> do         out <- evaluate $ writeChunkDirect h s -- ensure exceptions occur on this thread-        writeChan chan $ out >> tryPutMVar kick () >> return True+        writeChan chan $ out >> tryPutMVar kick () >> pure True   writeChunk :: Chunks -> Builder -> IO ()@@ -99,10 +99,10 @@ restoreChunksBackup file = do     -- complete a partially failed compress     b <- doesFileExist $ backup file-    if not b then return False else do+    if not b then pure False else do         removeFile_ file         renameFile (backup file) file-        return True+        pure True   usingChunks :: Cleanup -> FilePath -> Maybe Seconds -> IO Chunks@@ -111,7 +111,7 @@     allocate cleanup         (putMVar h =<< openFile file ReadWriteMode)         (const $ hClose =<< takeMVar h)-    return $ Chunks file flush h+    pure $ Chunks file flush h   -- | The file is being compacted, if the process fails, use a backup.@@ -128,7 +128,7 @@         res <- act $ writeChunkDirect h         hFlush h         removeFile $ backup chunksFileName-        return res+        pure res   -- | The file got corrupted, return a new version.@@ -136,7 +136,7 @@ resetChunksCorrupt copy Chunks{..} = mask $ \restore -> do     h <- takeMVar chunksHandle     case copy of-        Nothing -> return h+        Nothing -> pure h         Just copy -> do             flip onException (putMVar chunksHandle h) $ restore $ do                 hClose h

@@ -40,7 +40,7 @@     let clean = uninterruptibleMask_ $ do             items <- atomicModifyIORef' ref $ \s -> (s{items=Map.empty}, items s)             mapM_ snd $ sortOn (negate . fst) $ Map.toList items-    return (Cleanup ref, clean)+    pure (Cleanup ref, clean)   register :: Cleanup -> IO () -> IO ReleaseKey@@ -53,11 +53,11 @@ release :: ReleaseKey -> IO () release (ReleaseKey ref i) = uninterruptibleMask_ $ do     undo <- atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, Map.lookup i $ items s)-    fromMaybe (return ()) undo+    fromMaybe (pure ()) undo  allocate :: Cleanup -> IO a -> (a -> IO ()) -> IO a allocate cleanup acquire release =     mask_ $ do         v <- acquire         register cleanup $ release v-        return v+        pure v

@@ -13,6 +13,7 @@     ) where  import Data.Char+import Data.List.Extra import System.IO import System.Environment import System.IO.Unsafe@@ -26,18 +27,18 @@ #endif  checkEscCodes :: IO Bool-checkEscCodes = return checkEscCodesOnce+checkEscCodes = pure checkEscCodesOnce  {-# NOINLINE checkEscCodesOnce #-} checkEscCodesOnce :: Bool checkEscCodesOnce = unsafePerformIO $ do     hdl <- hIsTerminalDevice stdout     env <- maybe False (/= "dumb") <$> lookupEnv "TERM"-    if hdl && env then return True else+    if hdl && env then pure True else #ifdef mingw32_HOST_OS         checkEscCodesWindows #else-        return False+        pure False #endif  #ifdef mingw32_HOST_OS@@ -64,17 +65,17 @@     -- 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+        if b then Just <$> peek v else pure Nothing     case mode of-        Nothing -> return False+        Nothing -> pure False         Just mode -> do             let modeNew = mode .|. c_ENABLE_VIRTUAL_TERMINAL_PROCESSING-            if mode == modeNew then return True else do+            if mode == modeNew then pure True else do                 c_SetConsoleMode h modeNew #endif  removeEscCodes :: String -> String-removeEscCodes ('\ESC':'[':xs) = removeEscCodes $ drop 1 $ dropWhile (not . isAlpha) xs+removeEscCodes ('\ESC':'[':xs) = removeEscCodes $ drop1 $ dropWhile (not . isAlpha) xs removeEscCodes (x:xs) = x : removeEscCodes xs removeEscCodes [] = [] 

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RecordWildCards, GeneralizedNewtypeDeriving, ViewPatterns, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, GeneralizedNewtypeDeriving, ViewPatterns #-}  module General.Extra(     getProcessorCount,@@ -50,9 +49,7 @@ import Control.Monad import Control.Monad.ST import GHC.Conc(getNumProcessors)-#if __GLASGOW_HASKELL__ >= 800 import GHC.Stack-#endif   ---------------------------------------------------------------------@@ -122,7 +119,7 @@ {-# NOINLINE getProcessorCount #-} getProcessorCount :: IO Int -- unsafePefromIO so we cache the result and only compute it once-getProcessorCount = let res = unsafePerformIO act in return res+getProcessorCount = let res = unsafePerformIO act in pure res     where         act =             if rtsSupportsBoundThreads then@@ -130,10 +127,10 @@             else do                 env <- lookupEnv "NUMBER_OF_PROCESSORS"                 case env of-                    Just s | [(i,"")] <- reads s -> return i+                    Just s | [(i,"")] <- reads s -> pure i                     _ -> do-                        src <- readFile' "/proc/cpuinfo" `catchIO` \_ -> return ""-                        return $! max 1 $ length [() | x <- lines src, "processor" `isPrefixOf` x]+                        src <- readFile' "/proc/cpuinfo" `catchIO` \_ -> pure ""+                        pure $! max 1 $ length [() | x <- lines src, "processor" `isPrefixOf` x]   -- Can you find a GCC executable? return a Bool, and optionally something to add to $PATH to run it@@ -147,9 +144,9 @@                 Just ghc -> do                     let gcc = takeDirectory (takeDirectory ghc) </> "mingw/bin/gcc.exe"                     b <- doesFileExist_ gcc-                    return $ if b then (True, Just $ takeDirectory gcc) else (False, Nothing)-                _ -> return (False, Nothing)-        _ -> return (isJust v, Nothing)+                    pure $ if b then (True, Just $ takeDirectory gcc) else (False, Nothing)+                _ -> pure (False, Nothing)+        _ -> pure (isJust v, Nothing)   @@ -160,7 +157,7 @@ randomElem xs = do     when (null xs) $ fail "General.Extra.randomElem called with empty list, can't pick a random element"     i <- randomRIO (0, length xs - 1)-    return $ xs !! i+    pure $ xs !! i   ---------------------------------------------------------------------@@ -190,11 +187,11 @@ 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 [] f = pure $ Just [] forNothingM (x:xs) f = do     v <- f x     case v of-        Nothing -> return Nothing+        Nothing -> pure Nothing         Just v -> liftM (v:) `liftM` forNothingM xs f  @@ -235,16 +232,16 @@ -- System.Directory  doesFileExist_ :: FilePath -> IO Bool-doesFileExist_ x = doesFileExist x `catchIO` \_ -> return False+doesFileExist_ x = doesFileExist x `catchIO` \_ -> pure False  doesDirectoryExist_ :: FilePath -> IO Bool-doesDirectoryExist_ x = doesDirectoryExist x `catchIO` \_ -> return False+doesDirectoryExist_ x = doesDirectoryExist x `catchIO` \_ -> pure False  -- | Remove a file, but don't worry if it fails removeFile_ :: FilePath -> IO () removeFile_ x =     removeFile x `catchIO` \e ->-        when (isPermissionError e) $ handleIO (\_ -> return ()) $ do+        when (isPermissionError e) $ handleIO (\_ -> pure ()) $ do             perms <- getPermissions x             setPermissions x perms{readable = True, searchable = True, writable = True}             removeFile x@@ -271,14 +268,12 @@ type Located = Partial  callStackTop :: Partial => String-callStackTop = withFrozenCallStack $ head $ callStackFull ++ ["unknown location"]+callStackTop = withFrozenCallStack $ headDef "unknown location" callStackFull  callStackFull :: Partial => [String] callStackFromException :: SomeException -> ([String], SomeException)  -#if __GLASGOW_HASKELL__ >= 800- -- | Invert 'prettyCallStack', which GHC pre-applies in certain cases parseCallStack = reverse . map trimStart . drop 1 . lines @@ -287,14 +282,6 @@ callStackFromException (fromException -> Just (ErrorCallWithLocation msg loc)) = (parseCallStack loc, toException $ ErrorCall msg) callStackFromException e = ([], e) -#else--callStackFull = []-callStackFromException e = ([], e)--withFrozenCallStack :: a -> a-withFrozenCallStack = id-#endif  --------------------------------------------------------------------- -- Data.Version

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-}  module General.Fence(     Fence, newFence, signalFence, waitFence, testFence,@@ -21,20 +22,20 @@ instance Show (Fence m a) where show _ = "Fence"  newFence :: MonadIO m => IO (Fence m a)-newFence = Fence <$> newIORef (Left $ const $ return ())+newFence = Fence <$> newIORef (Left $ const $ pure ())  signalFence :: (Partial, MonadIO m) => Fence m a -> a -> m ()-signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \x -> case x of+signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \case     Left queue -> (Right v, queue v)     Right _ -> throwImpure $ errorInternal "signalFence called twice on one Fence"  waitFence :: MonadIO m => Fence m a -> (a -> m ()) -> m ()-waitFence (Fence ref) call = join $ liftIO $ atomicModifyIORef' ref $ \x -> case x of-    Left queue -> (Left (\a -> queue a >> call a), return ())+waitFence (Fence ref) call = join $ liftIO $ atomicModifyIORef' ref $ \case+    Left queue -> (Left (\a -> queue a >> call a), pure ())     Right v -> (Right v, call v)  testFence :: Fence m a -> IO (Maybe a)-testFence (Fence x) = either (const Nothing) Just <$> readIORef x+testFence (Fence x) = eitherToMaybe <$> readIORef x   ---------------------------------------------------------------------@@ -50,5 +51,5 @@         join $ liftIO $ atomicModifyIORef' todo $ \i -> case res of             Left e | i >= 0 -> (-1, signalFence fence $ Left e)             _ | i == 1 -> (-1, signalFence fence . Right =<< liftIO (mapM (fmap (fromRight' . fromJust) . testFence) xs))-              | otherwise -> (i-1, return ())-    return fence+              | otherwise -> (i-1, pure ())+    pure fence

@@ -58,7 +58,7 @@ 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]]+optionsEnum = optionsEnumDesc [(x, "Flag " ++ lower (show x) ++ ".") | x <- enumerate]  optionsEnumDesc :: Show a => [(a, String)] -> [OptDescr (Either String a)] optionsEnumDesc xs = [Option "" [lower $ show x] (NoArg $ Right x) d | (x,d) <- xs]

@@ -51,14 +51,14 @@ sizeUpperBound :: Ids a -> IO Int sizeUpperBound (Ids ref) = do     S{..} <- readIORef ref-    return used+    pure used   size :: Ids a -> IO Int size (Ids ref) = do     S{..} <- readIORef ref     let go !acc i-            | i < 0 = return acc+            | i < 0 = pure acc             | otherwise = do                 v <- readArray values i                 if isJust v then go (acc+1) (i-1) else go acc (i-1)@@ -68,12 +68,12 @@ toMap :: Ids a -> IO (Map.HashMap Id a) toMap ids = do     mp <- Map.fromList <$> toListUnsafe ids-    return $! mp+    pure $! mp  forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO () forWithKeyM_ (Ids ref) f = do     S{..} <- readIORef ref-    let go !i | i >= used = return ()+    let go !i | i >= used = pure ()               | otherwise = do                 v <- readArray values i                 whenJust v $ f $ Id $ fromIntegral i@@ -84,7 +84,7 @@ forCopy (Ids ref) f = do     S{..} <- readIORef ref     values2 <- newArray capacity Nothing-    let go !i | i >= used = return ()+    let go !i | i >= used = pure ()               | otherwise = do                 v <- readArray values i                 whenJust v $ \v -> writeArray values2 i $ Just $ f v@@ -96,7 +96,7 @@ forMutate :: Ids a -> (a -> a) -> IO () forMutate (Ids ref) f = do     S{..} <- readIORef ref-    let go !i | i >= used = return ()+    let go !i | i >= used = pure ()               | otherwise = do                 v <- readArray values i                 whenJust v $ \v -> writeArray values i $ Just $ f v@@ -124,7 +124,7 @@     let demand (_:xs) = demand xs         demand [] = ()     evaluate $ demand xs-    return xs+    pure xs  elems :: Ids a -> IO [a] elems ids = map snd <$> toList ids@@ -141,7 +141,7 @@         writeArray values ii $ Just v         when (ii >= used) $ writeIORef' ref S{used=ii+1,..}      else do-        c2 <- return $ max (capacity * 2) (ii + 10000)+        c2<- pure $ max (capacity * 2) (ii + 10000)         v2 <- newArray c2 Nothing         copyMutableArray v2 0 values 0 capacity         writeArray v2 ii $ Just v@@ -154,4 +154,4 @@     if ii < used then         readArray values ii      else-        return Nothing+        pure Nothing

@@ -52,11 +52,11 @@  emptyS :: Int -> Bool -> IO S emptyS n deterministic = do-    rand <- if not deterministic then return randomIO else do+    rand <- if not deterministic then pure randomIO else do         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 True Set.empty n 0 0 0 rand Heap.empty+        pure $ do i <- readIORef ref; writeIORef' ref (i+1); pure i+    pure $ S True Set.empty n 0 0 0 rand Heap.empty   data Pool = Pool@@ -66,15 +66,15 @@  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 ())+    if alive s then f s else pure (s, pure ())  withPool_ :: Pool -> (S -> IO S) -> IO ()-withPool_ pool act = withPool pool $ fmap (, return()) . act+withPool_ pool act = withPool pool $ fmap (, pure()) . act   worker :: Pool -> IO ()-worker pool = withPool pool $ \s -> return $ case Heap.uncons $ todo s of-    Nothing -> (s, return ())+worker pool = withPool pool $ \s -> pure $ case Heap.uncons $ todo s of+    Nothing -> (s, pure ())     Just (Heap.Entry _ now, todo2) -> (s{todo = todo2}, now >> worker pool)  -- | Given a pool, and a function that breaks the S invariants, restore them.@@ -90,14 +90,14 @@             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}+                    pure (remThread t s){alive = False}                 Right _ ->-                    step pool $ return . remThread t-            return (addThread t s){todo = todo2}+                    step pool $ pure . remThread t+            pure (addThread t s){todo = todo2}         Nothing | threadsCount s == 0 -> do             signalBarrier done $ Right s-            return s{alive = False}-        _ -> return s+            pure s{alive = False}+        _ -> pure 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)}@@ -109,7 +109,7 @@ addPool :: PoolPriority -> Pool -> IO a -> IO () addPool priority pool act = step pool $ \s -> do     i <- rand s-    return s{todo = Heap.insert (Heap.Entry (priority, i) $ void act) $ todo s}+    pure s{todo = Heap.insert (Heap.Entry (priority, i) $ void act) $ todo s}   data PoolPriority@@ -124,8 +124,8 @@ --   After calling cleanup you should requeue onto a new thread. increasePool :: Pool -> IO (IO ()) increasePool pool = do-    step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}-    return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1}+    step pool $ \s -> pure s{threadsLimit = threadsLimit s + 1}+    pure $ step pool $ \s -> pure s{threadsLimit = threadsLimit s - 1}   -- | Make sure the pool cannot run out of tasks (and thus everything finishes) until after the cancel is called.@@ -137,7 +137,7 @@         cancel <- increasePool pool         waitBarrier bar         cancel-    return $ signalBarrier bar ()+    pure $ signalBarrier bar ()   -- | Run all the tasks in the pool on the given number of works.@@ -149,7 +149,7 @@     let pool = Pool s done      -- 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 cleanup = join $ modifyVar s $ \s -> pure (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

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}  -- | A wrapping of createProcess to provide a more flexible interface.@@ -19,7 +20,7 @@ import System.Process import System.Time.Extra import Data.Unique-import Data.IORef+import Data.IORef.Extra import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import General.Extra@@ -38,7 +39,7 @@ newBuffer = liftM2 Buffer newUnique (newIORef [])  addBuffer :: Buffer a -> a -> IO ()-addBuffer (Buffer _ ref) x = atomicModifyIORef ref $ \xs -> (x:xs, ())+addBuffer (Buffer _ ref) x = atomicModifyIORef_ ref (x:)  readBuffer :: Buffer a -> IO [a] readBuffer (Buffer _ ref) = reverse <$> readIORef ref@@ -51,6 +52,7 @@     = SrcFile FilePath     | SrcString String     | SrcBytes LBS.ByteString+    | SrcInherit  data Destination     = DestEcho@@ -72,6 +74,7 @@     ,poStderr :: [Destination]     ,poAsync :: Bool     ,poCloseFds :: Bool+    ,poGroup :: Bool     }  @@ -80,7 +83,7 @@  -- | If two buffers can be replaced by one and a copy, do that (only if they start empty) optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())-optimiseBuffers po@ProcessOpts{..} = return (po{poStdout = nubOrd poStdout, poStderr = nubOrd poStderr}, return ())+optimiseBuffers po@ProcessOpts{..} = pure (po{poStdout = nubOrd poStdout, poStderr = nubOrd poStderr}, pure ())  stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream stdStream _ [DestEcho] _ = Inherit@@ -89,19 +92,20 @@   stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())-stdIn _ [] = (Inherit, const $ return ())-stdIn file [SrcFile x] = (UseHandle $ file x, const $ return ())+stdIn _ [SrcInherit] = (Inherit, const $ pure ())+stdIn file [SrcFile x] = (UseHandle $ file x, const $ pure ()) stdIn file src = (,) CreatePipe $ \h -> ignoreSigPipe $ do-    forM_ src $ \x -> case x of+    forM_ src $ \case         SrcString x -> hPutStr h x         SrcBytes x -> LBS.hPutStr h x         SrcFile x -> LBS.hPutStr h =<< LBS.hGetContents (file x)+        SrcInherit -> pure () -- Can't both inherit and set it     hClose h   ignoreSigPipe :: IO () -> IO () ignoreSigPipe = handleIO $ \e -> case e of-    IOError {ioe_type=ResourceVanished, ioe_errno=Just ioe} | Errno ioe == ePIPE -> return ()+    IOError {ioe_type=ResourceVanished, ioe_errno=Just ioe} | Errno ioe == ePIPE -> pure ()     _ -> throwIO e  @@ -113,7 +117,7 @@         unmask (waitBarrier bar) `onException` do             forkIO stop             waitBarrier bar-    either throwIO return v+    either throwIO pure v   withTimeout :: Maybe Double -> IO () -> IO a -> IO a@@ -131,16 +135,17 @@ forkWait a = do     res <- newEmptyMVar     _ <- mask $ \restore -> forkIO $ try_ (restore a) >>= putMVar res-    return $ takeMVar res >>= either throwIO return+    pure $ takeMVar res >>= either throwIO pure  -abort :: ProcessHandle -> IO ()-abort pid = do-    interruptProcessGroupOf pid-    sleep 3 -- give the process a few seconds grace period to die nicely-    -- seems to happen with some GHC 7.2 compiled binaries with FFI etc+abort :: Bool -> ProcessHandle -> IO ()+abort poGroup pid = do+    when poGroup $ do+        interruptProcessGroupOf pid+        sleep 3 -- give the process a few seconds grace period to die nicely     terminateProcess pid + withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a withFiles mode files act = withs (map (`withFile` mode) files) $ \handles ->     act $ \x -> fromJust $ lookup x $ zipExact files handles@@ -153,11 +158,11 @@     let outFiles = nubOrd [x | DestFile x <- poStdout ++ poStderr]     let inFiles = nubOrd [x | SrcFile x <- poStdin]     withFiles WriteMode outFiles $ \outHandle -> withFiles ReadMode inFiles $ \inHandle -> do-        let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = True, close_fds = poCloseFds+        let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = poGroup, close_fds = poCloseFds                  ,std_in = fst $ stdIn inHandle poStdin                  ,std_out = stdStream outHandle poStdout poStderr, std_err = stdStream outHandle poStderr poStdout}         withCreateProcessCompat cp $ \inh outh errh pid ->-            withExceptions (abort pid) $ withTimeout poTimeout (abort pid) $ do+            withTimeout poTimeout (abort poGroup pid) $ withExceptions (abort poGroup pid) $ do                  let streams = [(outh, stdout, poStdout) | Just outh <- [outh], CreatePipe <- [std_out cp]] ++                               [(errh, stderr, poStderr) | Just errh <- [errh], CreatePipe <- [std_err cp]]@@ -169,12 +174,12 @@                     when (DestEcho `elem` dest) $ do                         buf <- hGetBuffering hh                         case buf of-                            BlockBuffering{} -> return ()+                            BlockBuffering{} -> pure ()                             _ -> hSetBuffering h buf                      if isBinary then do                         hSetBinaryMode h True-                        dest <- return $ flip map dest $ \d -> case d of+                        dest<- pure $ flip map dest $ \case                             DestEcho -> BS.hPut hh                             DestFile x -> BS.hPut (outHandle x)                             DestString x -> addBuffer x . (if isWindows then replace "\r\n" "\n" else id) . BS.unpack@@ -184,36 +189,36 @@                             mapM_ ($ src) dest                             notM $ hIsEOF h                      else if isTied then do-                        dest <- return $ flip map dest $ \d -> case d of+                        dest<- pure $ flip map dest $ \case                             DestEcho -> hPutStrLn hh                             DestFile x -> hPutStrLn (outHandle x)                             DestString x -> addBuffer x . (++ "\n")                             DestBytes{} -> throwImpure $ errorInternal "Not reachable due to isBinary condition"                         forkWait $ whileM $-                            ifM (hIsEOF h) (return False) $ do+                            ifM (hIsEOF h) (pure False) $ do                                 src <- hGetLine h                                 mapM_ ($ src) dest-                                return True+                                pure True                      else do                         src <- hGetContents h                         wait1 <- forkWait $ C.evaluate $ rnf src-                        waits <- forM dest $ \d -> case d of+                        waits <- forM dest $ \case                             DestEcho -> forkWait $ hPutStr hh src                             DestFile x -> forkWait $ hPutStr (outHandle x) src-                            DestString x -> do addBuffer x src; return $ return ()+                            DestString x -> do addBuffer x src; pure $ pure ()                             DestBytes{} -> throwImpure $ errorInternal "Not reachable due to isBinary condition"-                        return $ sequence_ $ wait1 : waits+                        pure $ sequence_ $ wait1 : waits                  whenJust inh $ snd $ stdIn inHandle poStdin                 if poAsync then-                    return (pid, ExitSuccess)+                    pure (pid, ExitSuccess)                  else do                     sequence_ wait                     flushBuffers                     res <- waitForProcess pid                     whenJust outh hClose                     whenJust errh hClose-                    return (pid, res)+                    pure (pid, res)   ---------------------------------------------------------------------

@@ -27,7 +27,7 @@  -- Very hard to abstract over TH, so we do it with CPP #ifdef FILE_EMBED-#define FILE(x) (return (LBS.fromStrict $(embedFile =<< runIO (x))))+#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x)))) #else #define FILE(x) (LBS.readFile =<< (x)) #endif@@ -52,9 +52,9 @@         link = LBS.pack "<link href=\""         script = LBS.pack "<script src=\"" -        f x | Just file <- lbsStripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"-            | Just file <- lbsStripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"-            | otherwise = return x+        f x | Just file <- lbsStripPrefix script y = do res <- grab file; pure $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+            | Just file <- lbsStripPrefix link y = do res <- grab file; pure $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"+            | otherwise = pure x             where                 y = LBS.dropWhile isSpace x                 grab = asker . takeWhile (/= '\"') . LBS.unpack@@ -67,7 +67,7 @@         asker "shake.js" = readDataFileHTML "shake.js"         asker "data/metadata.js" = do             time <- getCurrentTime-            return $ LBS.pack $+            pure $ LBS.pack $                 "var version = " ++ show shakeVersionString ++                 "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time)         asker x = ask x@@ -78,7 +78,7 @@ -- before it starts producing the lazy result, killing streaming and having more stack usage. -- The real solution (albeit with too many dependencies for something small) is a streaming library, -- but a little bit of unsafePerformIO does the trick too.-lbsMapLinesIO f = return . LBS.unlines . map (unsafePerformIO . f) . LBS.lines+lbsMapLinesIO f = pure . LBS.unlines . map (unsafePerformIO . f) . LBS.lines   ---------------------------------------------------------------------

@@ -32,13 +32,13 @@         res <- try $ unmask act         me <- myThreadId         cleanup (Thread me bar) res-    return $ Thread t bar+    pure $ 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]+    bars <- sequence [do forkIO $ killThread t; pure bar | Thread t bar <- threads]     mapM_ waitBarrier bars  @@ -63,13 +63,13 @@         res :: Either SomeException (a,b) <- try $ unmask $ do             Right v1 <- waitBarrier bar1             Right v2 <- waitBarrier bar2-            return (v1,v2)+            pure (v1,v2)         writeVar ignore True         killThread t1         forkIO $ killThread t2         waitBarrier bar1         waitBarrier bar2-        either throwIO return res+        either throwIO pure res   -- | Run an action in a separate thread.

@@ -1,9 +1,10 @@  module General.Timing(resetTimings, addTiming, getTimings) where -import Data.IORef+import Data.IORef.Extra import System.IO.Unsafe import Data.Tuple.Extra+import Data.List.Extra import Numeric.Extra import General.Extra import System.Time.Extra@@ -30,13 +31,13 @@ getTimings = do     now <- timer     old <- atomicModifyIORef timings dupe-    return $ showTimings now $ reverse old+    pure $ showTimings now $ reverse old   addTiming :: String -> IO () addTiming msg = do     now <- timer-    atomicModifyIORef timings $ \ts -> ((now,msg):ts, ())+    atomicModifyIORef_ timings ((now,msg):)   showTimings :: Seconds -> [(Seconds, String)] -> [String]@@ -51,7 +52,7 @@         mx = maximum $ map snd xs         sm = sum $ map snd xs         xs = [ (name, stop - start)-             | ((start, name), stop) <- zipExact times $ map fst (drop 1 times) ++ [stop]]+             | ((start, name), stop) <- zipExact times $ map fst (drop1 times) ++ [stop]]   showGap :: [(String,String)] -> [String]

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, CPP #-}+{-# LANGUAGE DeriveFunctor #-}  -- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence module General.Wait(@@ -12,15 +12,13 @@ import Data.List.Extra import Data.Primitive.Array import GHC.Exts(RealWorld)--#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail-#endif+import Prelude   runWait :: Monad m => Wait m a -> m (Wait m a) runWait (Lift x) = runWait =<< x-runWait x = return x+runWait x = pure x  fromLater :: Monad m => Wait m a -> (a -> m ()) -> m () fromLater (Lift x) f = do x <- x; fromLater x f@@ -41,14 +39,14 @@     Lift x <*> y = Lift $ (<*> y) <$> x     Later x <*> Now y = Later $ \c -> x $ \x -> c $ x y     -- Note: We pull the Lift from the right BEFORE the Later, to enable parallelism-    Later x <*> Lift y = Lift $ do y <- y; return $ Later x <*> y+    Later x <*> Lift y = Lift $ do y <- y; pure $ Later x <*> y     Later x <*> Later y = Later $ \c -> x $ \x -> y $ \y -> c $ x y  instance (Monad m, Applicative m) => Monad (Wait m) where     return = pure     (>>) = (*>)     Now x >>= f = f x-    Lift x >>= f = Lift $ do x <- x; return $ x >>= f+    Lift x >>= f = Lift $ do x <- x; pure $ x >>= f     Later x >>= f = Later $ \c -> x $ \x -> do         x <- runWait $ f x         case x of@@ -58,16 +56,9 @@ instance (MonadIO m,  Applicative m) => MonadIO (Wait m) where     liftIO = Lift . liftIO . fmap Now -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 instance MonadFail m => MonadFail (Wait m) where     fail = Lift . Control.Monad.Fail.fail-#endif-#if __GLASGOW_HASKELL__ >= 808-instance MonadFail m => MonadFail (Wait m) where-    fail = Lift . Prelude.fail-#endif - firstJustWaitUnordered :: MonadIO m => (a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b) firstJustWaitUnordered f = go [] . map f     where@@ -79,7 +70,7 @@             Later l -> go (l:later) xs             Lift x -> Lift $ do                 x <- x-                return $ go later (x:xs)+                pure $ go later (x:xs)         go [] [] = Now Nothing         go [l] [] = Later l         go ls [] = Later $ \callback -> do@@ -101,7 +92,7 @@         mut <- liftIO $ newArray n undefined         res <- go mut [] $ zipFrom 0 $ map f xs         case res of-            Just e -> return $ Left e+            Just e -> pure $ Left e             Nothing -> liftIO $ Right <$> mapM (readArray mut) [0..n-1]     where         -- keep a list of those things we might visit later, and ask for each we see in turn@@ -114,7 +105,7 @@             Later l -> go mut ((i,l):later) xs             Lift x -> Lift $ do                 x <- x-                return $ go mut later ((i,x):xs)+                pure $ go mut later ((i,x):xs)         go _ [] [] = Now Nothing         go mut ls [] = Later $ \callback -> do             ref <- liftIO $ newIORef $ length ls

@@ -6,7 +6,7 @@  -- If Shake can't find files in the data directory it tries relative to the executable getDataDir :: IO FilePath-getDataDir = return "random_path_that_cannot_possibly_exist"+getDataDir = pure "random_path_that_cannot_possibly_exist"  version :: Version version = makeVersion [0,0]

@@ -25,19 +25,20 @@         ,"Shakefile.hs","Shakefile.lhs"]     case hsExe of         Just file -> do-            (prog,args) <- return $+            (prog,args)<- pure $                 if takeExtension file `elem` [".hs",".lhs"] then ("runhaskell", file:args) else (toNative file, args)             e <- rawSystem prog args             when (e /= ExitSuccess) $ exitWith e         Nothing -> do-            let go = shakeArgsWith shakeOptions{shakeThreads=0,shakeCreationCheck=False} flags $ \opts targets -> do+            let opts = shakeOptions{shakeThreads=0,shakeCreationCheck=False,shakeNeedDirectory=True}+            let go = shakeArgsWith opts flags $ \opts targets -> do                         let tool = listToMaybe [x | Tool x <- opts]                         makefile <- case reverse [x | UseMakefile x <- opts] of-                            x:_ -> return x+                            x:_ -> pure x                             _ -> do                                 res <- findFile ["build.ninja"]                                 case res of-                                    Just x -> return x+                                    Just x -> pure x                                     Nothing -> errorIO "Could not find `build.ninja'"                         runNinja go makefile targets tool             withArgs ("--no-time":args) go

@@ -4,6 +4,7 @@ import Control.Exception.Extra import Control.Monad.Extra import Data.Maybe+import Data.List.Extra import System.Directory import System.Environment import General.Timing@@ -153,14 +154,14 @@ makefile :: IO () -> IO () makefile _ = do     args <- getArgs-    withArgs (drop 1 args) Run.main+    withArgs (drop1 args) Run.main   filetime :: IO () -> IO () filetime _ = do     args <- getArgs     addTiming "Reading files"-    files <- fmap concat $ forM (drop 1 args) $ \file ->+    files <- concatForM (drop1 args) $ \file ->         BS.lines . BS.filter (/= '\r') <$> BS.readFile file     let n = length files     evaluate n@@ -169,7 +170,7 @@     let (b,cd) = splitAt (n `div` 4) bcd     let (c,d) = splitAt (n `div` 4) cd     vars <- forM [a,b,c,d] $ \xs ->-        onceFork $ mapM_ (getFileInfo . fileNameFromByteString) xs+        onceFork $ mapM_ (getFileInfo False . fileNameFromByteString) xs     sequence_ vars  @@ -181,4 +182,4 @@ test yield = do     args <- getArgs     flip onException (putStrLn "TESTS FAILED") $-        sequence_ [withArgs (name:"test":drop 1 args) $ test yield | (name,test) <- mains, name /= "random"]+        sequence_ [withArgs (name:"test":drop1 args) $ test yield | (name,test) <- mains, name /= "random"]

@@ -53,8 +53,8 @@         x <- getShakeOptions         writeFile' "threads.txt" $ show $ shakeThreads x -    phony ("slash" </> "platform") $ return ()-    phony "slash/forward" $ return ()+    phony ("slash" </> "platform") $ pure ()+    phony "slash/forward" $ pure ()      phony "options" $ do         opts <- getShakeOptions@@ -78,7 +78,7 @@     ["sep" </> "3.txt", "sep" </> "4.txt", "sep" </> "5.*", "sep/6.txt"] |%> \out -> writeFile' out ""     ["sep" </> "7.txt"] |%> \out -> writeFile' out "" -    "ids/source" %> \_ -> return ()+    "ids/source" %> \_ -> pure ()     "ids/out" %> \out -> do need =<< readFileLines "ids/source"; writeFile' out ""     "ids/*" %> \out -> do alwaysRerun; trace (takeFileName out); writeFile' out $ takeFileName out 

@@ -4,6 +4,7 @@ import Development.Shake import Development.Shake.FilePath import System.Directory+import Data.List import General.Extra import Test.Type import Control.Monad@@ -12,7 +13,7 @@ main = testBuild test $ do     let inp x = x -<.> "in"     file <- newResource "log.txt" 1-    batch 3 ("*.out" %>) (\out -> do need [inp out]; return out) $ \outs -> do+    batch 3 ("*.out" %>) (\out -> do need [inp out]; pure out) $ \outs -> do         liftIO $ assertBool (length outs <= 3) "length outs <= 3"         withResource file 1 $ liftIO $ appendFile "log.txt" $ show (length outs) ++ "\n"         putInfo $ "Building batch: " ++ unwords outs@@ -35,14 +36,20 @@         o <- resultHasChanged out         writeFileLines out $ xs ++ ["On" | o] -    batch maxBound ("batch_max.*" %>) return $ \outs ->+    batch maxBound ("batch_max.*" %>) pure $ \outs ->         forM_ outs $ \out -> writeFile' out $ show $ length outs +    phony "sleep2" $ liftIO $ sleep 2+    batch 2 ("batch_profile.*" %>) (\x -> when ("1" `isSuffixOf` x) (liftIO $ sleep 1) >> pure x) $ \outs -> do+        liftIO $ sleep 2+        need ["sleep2"]+        forM_ outs $ \out -> writeFile' out "" + test build = do     forM_ [1..6] $ \i -> writeFile (show i <.> "in") $ show i     build ["--sleep","-j2"]-    assertBoolIO (do src <- readFile "log.txt"; return $ length (lines src) < 6) "some batching"+    assertBoolIO (do src <- readFile "log.txt"; pure $ length (lines src) < 6) "some batching"     writeFile "log.txt" ""     writeFile "2.in" "22"     writeFile "5.in" "55"@@ -96,3 +103,7 @@      build ["batch_max." ++ show i | i <- [1..100]]     assertContents "batch_max.72" "100"++    let names = ["batch_profile." ++ show i | i <- [1..2]]+    build names+    assertTimings build $ ("sleep2",2) : zip names [2,1]

@@ -5,6 +5,7 @@ import Development.Shake import Test.Type import Text.Read+import Data.List.Extra import Development.Shake.FilePath  @@ -14,8 +15,8 @@  -- | Given a breadth and depth come up with a set of build files main = testBuildArgs test opts $ \opts -> do-    let depth   = last $ 75 : [x | Depth   x <- opts]-    let breadth = last $ 75 : [x | Breadth x <- opts]+    let depth   = lastDef 75 [x | Depth   x <- opts]+    let breadth = lastDef 75 [x | Breadth x <- opts]      want ["0." ++ show i | i <- [1..breadth]]     "*" %> \out -> do

@@ -24,18 +24,18 @@ addBuiltinFileRule :: Rules () addBuiltinFileRule = addBuiltinRule noLint noIdentity run     where-        fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else return ""+        fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else pure ""          run :: BuiltinRun File ()         run key old mode = do             now <- liftIO $ fileContents key             if mode == RunDependenciesSame && fmap BS.unpack old == Just now then-                return $ RunResult ChangedNothing (BS.pack now) ()+                pure $ RunResult ChangedNothing (BS.pack now) ()             else do                 (_, act) <- getUserRuleOne key (const Nothing) $ \(FileRule k act) -> if k == key then Just act else Nothing                 act                 now <- liftIO $ fileContents key-                return $ RunResult ChangedRecomputeDiff (BS.pack now) ()+                pure $ RunResult ChangedRecomputeDiff (BS.pack now) ()  fileRule :: FilePath -> Action () -> Rules () fileRule file act = addUserRule $ FileRule (File file) act@@ -47,7 +47,7 @@ main = testBuild test $ do     addBuiltinFileRule -    fileRule "a.txt" $ return ()+    fileRule "a.txt" $ pure ()     fileRule "b.txt" $ do         fileNeed "a.txt"         liftIO $ appendFile "log.txt" "X"

@@ -25,4 +25,4 @@ cIncludes :: FilePath -> Action [FilePath] cIncludes x = do     Stdout stdout <- cmd "gcc" ["-MM",x]-    return $ drop 2 $ words stdout+    pure $ drop 2 $ words stdout

@@ -12,7 +12,7 @@     vowels <- newCache $ \file -> do         src <- readFile' file         liftIO $ appendFile "trace.txt" "1"-        return $ length $ filter isDigit src+        pure $ length $ filter isDigit src     "*.out*" %> \x ->         writeFile' x . show =<< vowels (dropExtension x <.> "txt") 

@@ -15,7 +15,7 @@ main = testSimple $ do     do -- survives releasing bottom         x <- newIORef (0 :: Int)-        handle (\(_ :: SomeException) -> return ()) $ withCleanup $ \cleanup -> do+        handle (\(_ :: SomeException) -> pure ()) $ withCleanup $ \cleanup -> do             _ <- register cleanup $ modifyIORef x (+1)             release undefined         (=== 1) =<< readIORef x@@ -47,7 +47,7 @@         Left Dummy <- try $ withCleanup $ \cleanup -> do             register cleanup (checkMasked "exception")             throwIO Dummy-        return ()+        pure ()   data Dummy = Dummy

@@ -51,7 +51,7 @@             \file -> actionBracket (openFile file AppendMode) hClose $                 \h -> do fd <- liftIO $ handleToFd h                          (Exit c, Stdout _, Stderr _) <- cmdWithOpts helper (show fd) :: Action (Exit, Stdout String, Stderr String)-                         return c+                         pure c      "defaultbehaviour" !> do         c <- callWithOpenFile cmd

@@ -98,12 +98,14 @@      "timeout2" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "w20" -    -- commented out beause on Windows when you abort a Shell process you get a-    -- Do you want to terminate the batch file (Y/N)-    when False $ "timeout3" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ Shell helper "w20"+    -- disabled on Windows because when you abort a Shell process you get a+    -- "Do you want to terminate the batch file (Y/N)"+    unless isWindows $ "timeout3" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ Shell helper "w20"      "timeout4" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "sw20" +    "timeout5" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "i w20"+     "env" !> do         -- use liftIO since it blows away PATH which makes lint-tracker stop working         Stdout out <- liftIO $ cmd (Env [("FOO","HELLO SHAKE")]) Shell helper "vFOO"@@ -147,7 +149,7 @@         liftIO $ (===) (str, bs) $ second BS.pack $ dupe $ if isWindows then "foo\r\n" else "foo\n"         (Stdout str, Stdout bs) <- cmd helper "ofoo"         liftIO $ (str, bs) === ("foo\n", BS.pack $ if isWindows then "foo\r\n" else "foo\n")-        return ()+        pure ()      "large" !> do         (Stdout (_ :: String), CmdTime t1) <- cmd helper "r10000000"@@ -184,7 +186,7 @@ timer act = do     (CmdTime t, CmdLine x, r) <- act     liftIO $ putStrLn $ "Command " ++ x ++ " took " ++ show t ++ " seconds"-    return r+    pure r  waits :: (String -> IO ()) -> IO () waits op = f 0

@@ -5,7 +5,7 @@ import Development.Shake.FilePath import Development.Shake.Config import Test.Type-import Data.Char+import Data.List.Extra import qualified Data.HashMap.Strict as Map import Data.Maybe @@ -14,7 +14,7 @@     want ["hsflags.var","cflags.var","none.var","keys"]     usingConfigFile "config"     "*.var" %> \out -> do-        cfg <- getConfig $ map toUpper $ takeBaseName out+        cfg <- getConfig $ upper $ takeBaseName out         liftIO $ appendFile (out -<.> "times") "X"         writeFile' out $ fromMaybe "" cfg     "keys" %> \out -> do

@@ -33,7 +33,7 @@     (open, close) <- shakeOpenDatabase opts rules     db <- open -    ([12], after) <- shakeRunDatabase db [need ["a.out"] >> return 12]+    ([12], after) <- shakeRunDatabase db [need ["a.out"] >> pure 12]     assertContents "log.txt" "x"      writeFile "a.in" "A"@@ -41,7 +41,7 @@     assertContents "a.out" "A"     assertContents "log.txt" "xxx" -    ([13,14], _) <- shakeRunDatabase db [need ["a.out"] >> return 13, return 14]+    ([13,14], _) <- shakeRunDatabase db [need ["a.out"] >> pure 13, pure 14]     assertContents "log.txt" "xxx"      live <- shakeLiveFilesDatabase db@@ -77,10 +77,10 @@      -- check the progress thread gets killed properly on normal cleanup     ref <- newIORef 0-    opts <- return opts{shakeProgress = const $ bracket_ (modifyIORef ref succ) (modifyIORef ref succ) $ sleep 100}+    opts <- pure opts{shakeProgress = const $ bracket_ (modifyIORef ref succ) (modifyIORef ref succ) $ sleep 100}     (open, close) <- shakeOpenDatabase opts rules     db <- open-    ([12], after) <- shakeRunDatabase db [need ["a.out"] >> liftIO (modifyIORef ref succ) >> return 12]+    ([12], after) <- shakeRunDatabase db [need ["a.out"] >> liftIO (modifyIORef ref succ) >> pure 12]     (=== 3) =<< readIORef ref -- success if it all shuts down cleanly      -- and on an exception@@ -91,7 +91,7 @@     -- and on an external exception     writeIORef ref 0     bar <- newBarrier; bar2 <- newBarrier-    t <- flip forkFinally (signalBarrier bar2)  $ void $ shakeRunDatabase db $ return $ do+    t <- flip forkFinally (signalBarrier bar2)  $ void $ shakeRunDatabase db $ pure $ do         liftIO $ modifyIORef ref succ         liftIO $ signalBarrier bar ()         need ["sleep"]

@@ -23,7 +23,7 @@         writeFile' out1 "X"         writeFile' out2 "Y" -    "leaf" ~> return ()+    "leaf" ~> pure ()     "node1.txt" %> \file -> do need ["leaf"]; writeFile' file "x"     "node2.txt" %> \file -> do need ["node1.txt"]; liftIO $ appendFile file "x" 

@@ -10,7 +10,6 @@ import Control.Monad import Data.Char import Data.List.Extra-import Data.Maybe import System.Info import Data.Version.Extra @@ -87,6 +86,7 @@             ,"import Control.Concurrent"             ,"import Control.Exception"             ,"import Control.Monad"+            ,"import Control.Monad.Trans.Reader"             ,"import Data.ByteString(ByteString, pack, unpack)"             ,"import qualified Data.ByteString.Char8 as BS"             ,"import qualified System.Directory.Extra as IO"@@ -143,7 +143,7 @@             ,"instance Eq (OptDescr a)"             ,"(foo,bar,baz) = undefined"             ,"(p1,p2) = (0.0, 0.0)"-            ,"(r1,r2) = (return () :: Rules(), return () :: Rules())"+            ,"(r1,r2) = (pure () :: Rules(), pure () :: Rules())"             ,"xs = []"             ,"ys = []"             ,"os = [\"file.o\"]"@@ -171,11 +171,11 @@             ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd,                 takeBaseName x `notElem` ["Developing","Model","Architecture"]] -    let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; return mods+    let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; pure mods      "Main.hs" %> \out -> do         mods <- needModules-        writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m ++ "()" | m <- mods] ++ ["main = return ()"]+        writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m ++ "()" | m <- mods] ++ ["main = pure ()"]      "Success.txt" %> \out -> do         putInfo . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"@@ -212,7 +212,7 @@     in Code (dropWhileEnd isBlank $ unindent a) : findCodeMarkdown b     where         indented x = length (takeWhile isSpace x) >= 4-findCodeMarkdown (x:xs) = map (Code . return) (evens $ splitOn "`" x) ++ findCodeMarkdown xs+findCodeMarkdown (x:xs) = map (Code . pure) (evens $ splitOn "`" x) ++ findCodeMarkdown xs     where         evens (_:x:xs) = x : evens xs         evens _ = []@@ -223,7 +223,7 @@ -- RENDER THE CODE  showCode :: [Code] -> [String]-showCode = concat . zipWith f [1..] . nubOrd+showCode = concat . zipWithFrom f 1 . nubOrd     where         f i (Code x) | "#" `isPrefixOf` concat x = []                      | all whitelist x = []@@ -232,7 +232,7 @@  fixCmd :: [String] -> [String] fixCmd xs-    | all ("cmd_ " `isPrefixOf`) xs = xs ++ ["return () :: IO () "]+    | all ("cmd_ " `isPrefixOf`) xs = xs ++ ["pure () :: IO () "]     | otherwise = map (replace "Stdout out" "Stdout (out :: String)" . replace "Stderr err" "Stderr (err :: String)") xs  -- | Replace ... with undefined (don't use undefined with cmd; two ...'s should become one replacement)@@ -248,7 +248,7 @@ showStmt i [x] | filter isAlpha (fst $ word1 x) `elem` types = ["type Code_" ++ show i ++ " = " ++ x] showStmt i [x] | length (words x) <= 2 = ["code_" ++ show i ++ " = (" ++ x ++ ")"] -- deal with operators and sections showStmt i xs | all isPredicate xs, length xs > 1 =-    zipWith (\j x -> "code_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] xs+    zipWithFrom (\j x -> "code_" ++ show i ++ "_" ++ show j ++ " = " ++ x) 1 xs showStmt i xs = ("code_" ++ show i ++ " = do") : map ("  " ++) xs ++ ["  undefined" | isBindStmt $ last xs]  isPredicate :: String -> Bool@@ -282,11 +282,11 @@  -- | Find all pieces of text inside a given tag insideTag :: String -> String -> [String]-insideTag tag = map (fst . breakOn ("</" ++ tag ++ ">")) . drop 1 . splitOn ("<" ++ tag ++ ">")+insideTag tag = map (fst . breakOn ("</" ++ tag ++ ">")) . drop1 . splitOn ("<" ++ tag ++ ">")  -- | Given some HTML, find the raw text innerText :: String -> String-innerText ('<':xs) = innerText $ drop 1 $ dropWhile (/= '>') xs+innerText ('<':xs) = innerText $ drop1 $ dropWhile (/= '>') xs innerText ('&':xs)     | Just xs <- stripPrefix "quot;" xs = '\"' : innerText xs     | Just xs <- stripPrefix "lt;" xs = '<' : innerText xs@@ -307,7 +307,7 @@ -- | Identifiers that indicate the fragment is a type types :: [String] types = words $-    "MVar IO String FilePath Maybe [String] FSATrace Char ExitCode Change " +++    "MVar IO String FilePath Maybe [String] FSATrace Char ExitCode ReaderT Change " ++     "Action Resource Rebuild FilePattern Development.Shake.FilePattern " ++     "Lint Verbosity Rules CmdOption Int Double " ++     "NFData Binary Hashable Eq Typeable Show Applicative " ++@@ -332,7 +332,7 @@     where (a,b) = span (== '-') x  isCmdFlags :: String -> Bool-isCmdFlags = all (\x -> let y = fromMaybe x $ stripSuffix "," x in isCmdFlag y || isArg y) . words+isCmdFlags = all (\x -> let y = dropSuffix "," x in isCmdFlag y || isArg y) . words     where isArg = all (\x -> isUpper x || x == '=')  isEnvVar :: String -> Bool@@ -343,7 +343,7 @@  isProgram :: String -> Bool isProgram (words -> x:xs) = x `elem` programs && all (\x -> isCmdFlag x || isFilePath x || all isAlpha x || x == "&&") xs-    where programs = words "excel gcc cl make ghc ghci cabal distcc npm build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple"+    where programs = words "excel gcc docker cl make ghc ghci cabal distcc npm build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple" isProgram _ = False  -- | Should a fragment be whitelisted and not checked

@@ -26,14 +26,14 @@ type instance RuleResult BadBinary = BadBinary instance Binary BadBinary where     put (BadBinary x) = put x-    get = do x <- get; if x == "bad" then error "get: BadBinary \"bad\"" else return $ BadBinary x+    get = do x <- get; if x == "bad" then error "get: BadBinary \"bad\"" else pure $ BadBinary x  main = testBuildArgs test optionsEnum $ \args -> do     "norule" %> \_ ->         need ["norule_isavailable"]      "failcreate" %> \_ ->-        return ()+        pure ()      ["failcreates", "failcreates2"] &%> \_ ->         writeFile' "failcreates" ""@@ -60,12 +60,12 @@             writeFile' out "0"             op $ do src <- IO.readFile' out; writeFile out $ show (read src + 1 :: Int)     catcher "finally1" $ actionFinally $ fail "die"-    catcher "finally2" $ actionFinally $ return ()+    catcher "finally2" $ actionFinally $ pure ()     catcher "finally3" $ actionFinally $ liftIO $ sleep 10     catcher "finally4" $ actionFinally $ need ["wait"]     "wait" ~> do liftIO $ sleep 10     catcher "exception1" $ actionOnException $ fail "die"-    catcher "exception2" $ actionOnException $ return ()+    catcher "exception2" $ actionOnException $ pure ()      "retry*" %> \out -> do         ref <- liftIO $ newIORef 3@@ -93,7 +93,7 @@     "tempfile" %> \out -> do         file <- withTempFile $ \file -> do             liftIO $ assertExists file-            return file+            pure file         liftIO $ assertMissing file         withTempFile $ \file -> do             liftIO $ assertExists file@@ -106,7 +106,7 @@             liftIO $ writeFile (dir </> "foo.txt") ""                 -- will throw if the directory does not exist             writeFile' out ""-            return file+            pure file         liftIO $ assertMissing file      phony "fail1" $ fail "die1"@@ -141,7 +141,7 @@         liftIO $ sleep 20         writeFile' out "" -    addOracle $ \(BadBinary x) -> return $ BadBinary $ 'b':x+    addOracle $ \(BadBinary x) -> pure $ BadBinary $ 'b':x     "badinput" %> \out -> do         askOracle $ BadBinary "bad"         liftIO $ appendFile out "x"

@@ -11,17 +11,17 @@     cwd <- getCurrentDirectory     someFiles <- getDirectoryFilesIO cwd ["*"]     let someFile = head someFiles-    assertIsJust . getFileInfo $ fileNameFromString someFile+    assertIsJust $ getFileInfo False $ fileNameFromString someFile      let fileThatCantExist = someFile </> "fileThatCantExist"-    assertIsNothing . getFileInfo $ fileNameFromString fileThatCantExist+    assertIsNothing $ getFileInfo False $ fileNameFromString fileThatCantExist  assertIsJust :: IO (Maybe a) -> IO () assertIsJust action = do     Just _ <- action-    return ()+    pure ()  assertIsNothing :: IO (Maybe a) -> IO () assertIsNothing action = do     Nothing <- action-    return ()+    pure ()

@@ -7,7 +7,7 @@ import Test.Type import Test.QuickCheck import Control.Monad-import Data.List+import Data.List.Extra import qualified Data.ByteString.Char8 as BS import qualified Development.Shake.Internal.FileName as BS import System.Info.Extra@@ -18,7 +18,7 @@ newtype File = File String deriving Show  instance Arbitrary File where-    arbitrary = fmap File $ listOf $ oneof $ map return "a /\\:."+    arbitrary = fmap File $ listOf $ oneof $ map pure "a /\\:."     shrink (File x) = map File $ shrink x  @@ -66,7 +66,7 @@     Success{} <- quickCheckWithResult stdArgs{maxSuccess=1000} $ \(File x) ->         let y = norm x             sep = Native.isPathSeparator-            noDrive = if isWindows then drop 1 else id+            noDrive = if isWindows then drop1 else id             ps = [y /= ""                  ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y))                  ,not $ "/./" `isInfixOf` y

@@ -180,27 +180,27 @@     substitute  ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt"     substitute  ["foo/bar/","test"] "**/*a.txt" === "foo/bar/testa.txt" -    (False, Walk _) <- return $ walk ["*.xml"]-    (False, Walk _) <- return $ walk ["//*.xml"]-    (False, Walk _) <- return $ walk ["**/*.xml"]-    (False, WalkTo ([], [("foo",Walk _)])) <- return $ walk ["foo//*.xml"]-    (False, WalkTo ([], [("foo",Walk _)])) <- return $ walk ["foo/**/*.xml"]-    (False, WalkTo ([], [("foo",WalkTo ([],[("bar",Walk _)]))])) <- return $ walk ["foo/bar/*.xml"]-    (False, WalkTo (["a"],[("b",WalkTo (["c"],[]))])) <- return $ walk ["a","b/c"]-    ([], [("foo",WalkTo ([],[("bar",Walk _)]))]) <- let (False, Walk f) = walk ["*/bar/*.xml"] in return $ f ["foo"]-    (False, WalkTo ([],[("bar",Walk _),("baz",Walk _)])) <- return $ walk ["bar/*.xml","baz//*.c"]-    (False, WalkTo ([],[("bar",Walk _),("baz",Walk _)])) <- return $ walk ["bar/*.xml","baz/**/*.c"]-    (False, WalkTo ([], [])) <- return $ walk []-    (True, Walk _) <- return $ walk ["//"]-    (True, Walk _) <- return $ walk ["**"]-    (True, WalkTo _) <- return $ walk [""]+    (False, Walk _) <- pure $ walk ["*.xml"]+    (False, Walk _) <- pure $ walk ["//*.xml"]+    (False, Walk _) <- pure $ walk ["**/*.xml"]+    (False, WalkTo ([], [("foo",Walk _)])) <- pure $ walk ["foo//*.xml"]+    (False, WalkTo ([], [("foo",Walk _)])) <- pure $ walk ["foo/**/*.xml"]+    (False, WalkTo ([], [("foo",WalkTo ([],[("bar",Walk _)]))])) <- pure $ walk ["foo/bar/*.xml"]+    (False, WalkTo (["a"],[("b",WalkTo (["c"],[]))])) <- pure $ walk ["a","b/c"]+    ([], [("foo",WalkTo ([],[("bar",Walk _)]))]) <- let (False, Walk f) = walk ["*/bar/*.xml"] in pure $ f ["foo"]+    (False, WalkTo ([],[("bar",Walk _),("baz",Walk _)])) <- pure $ walk ["bar/*.xml","baz//*.c"]+    (False, WalkTo ([],[("bar",Walk _),("baz",Walk _)])) <- pure $ walk ["bar/*.xml","baz/**/*.c"]+    (False, WalkTo ([], [])) <- pure $ walk []+    (True, Walk _) <- pure $ walk ["//"]+    (True, Walk _) <- pure $ walk ["**"]+    (True, WalkTo _) <- pure $ walk [""]      Success{} <- quickCheckWithResult stdArgs{maxSuccess=1000} $ \(Pattern p) (Path x) ->         let label _ = property in             -- Ignore label to workaround QuickCheck space-leak             -- See #450 and https://github.com/nick8325/quickcheck/pull/93-        let b = p ?== x in (if b then property else label "No match") $ unsafePerformIO $ do f b p x; return True-    return ()+        let b = p ?== x in (if b then property else label "No match") $ unsafePerformIO $ do f b p x; pure True+    pure ()   walker :: FilePattern -> FilePath -> Bool

@@ -16,7 +16,7 @@     os <- forP cs $ \c -> do         let o = c <.> "o"         cache $ cmd "gcc -c" [c] "-o" [o]-        return o+        pure o     cache $ cmd "gcc -o" ["Main" <.> exe] os     cache $ cmd ["." </> "Main" <.> exe] (FileStdout "output.txt") 

@@ -19,7 +19,7 @@     let die :: a -> a         die x = if Die `elem` args then error "Die" else x -    phony "Phony" $ return ()+    phony "Phony" $ pure ()     "Phony.txt" %> \out -> do         need ["Phony"]         copyFile' "In.txt" out

@@ -20,7 +20,7 @@     addOracle $ \Zero{} -> do         liftIO $ createDirectoryRecursive "dir"         liftIO $ setCurrentDirectory "dir"-        return $ Zero ()+        pure $ Zero ()      "changedir" %> \out -> do         Zero () <- askOracle $ Zero ()

@@ -8,7 +8,7 @@ import Data.IORef import Control.Concurrent import Control.Exception-import Control.Monad+import Control.Monad.Extra import Control.Monad.IO.Class  @@ -17,8 +17,8 @@ run :: ro -> rw -> RAW () () ro rw a -> IO a run ro rw m = do     res <- newEmptyMVar-    runRAW return ro rw m $ void . tryPutMVar res-    either throwIO return =<< readMVar res+    runRAW pure ro rw m $ void . tryPutMVar res+    eitherM throwIO pure (readMVar res)   main = testSimple $ do@@ -34,7 +34,7 @@             dump "more"             modifyRW (++ "x")             dump "morex"-            return 100+            pure 100         liftIO $ conv res === Right 100         dump "morex"         putRW "new"@@ -45,7 +45,7 @@             dump "newz"             throwRAW Overflow             error "Should not have reached here"-            return 9+            pure 9         liftIO $ conv res === Left (Just Overflow)         dump "newz"         catchRAW (catchRAW (throwRAW Overflow) $ \_ -> modifyRW (++ "x")) $@@ -71,10 +71,10 @@     res === Left Overflow     res <- try $ run 1 "test" $ do         captureRAW $ \_ -> throwIO Overflow-        return "x"+        pure "x"     res === Left Overflow     -- test for GHC bug 11555-    runRAW return 1 "test" (throw Overflow :: RAW () () Int String ()) $ \res ->+    runRAW pure 1 "test" (throw Overflow :: RAW () () Int String ()) $ \res ->         mapLeft fromException res === Left (Just Overflow)      -- catch works properly if continuation called multiple times@@ -92,7 +92,7 @@      -- what if we throw an exception inside the continuation of run     ref <- newIORef 0-    res <- try $ runRAW return 1 "test" (return 1) $ \_ -> do+    res <- try $ runRAW pure 1 "test" (pure 1) $ \_ -> do         modifyIORef ref (+1)         throwIO Overflow     res === Left Overflow

@@ -9,7 +9,7 @@ import General.Extra import Test.Type import qualified Data.HashMap.Strict as Map-import Data.List+import Data.List.Extra import System.IO.Extra import qualified Run import System.Environment@@ -17,9 +17,13 @@  opts = Option "" ["arg"] (ReqArg Right "") "" +-- | Set to True to test with real Ninja+--   On Windows doesn't work because echo foo > 1 isn't supported+real_ninja = False+ main = testBuildArgs test [opts] $ \opts -> do     let real = "real" `elem` opts-    action $ if real+    action $ if real || real_ninja         then cmd "ninja" opts         else liftIO $ withArgs ("--lint":"--report=report.html":opts) Run.main @@ -75,7 +79,7 @@     run "-f../../src/Test/Ninja/lint.ninja good --lint"     runFail "-f../../src/Test/Ninja/lint.ninja bad --lint" "not a pre-dependency" -    res <- fmap (drop 1 . lines . fst) $ captureOutput $ runEx "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx" "--quiet"+    res <- fmap (drop1 . lines . fst) $ captureOutput $ runEx "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx" "--quiet"     want <- lines <$> readFile "../../src/Test/Ninja/compdb.output"     let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b                | otherwise = a === b@@ -111,6 +115,10 @@     copyFile "../../src/Test/Ninja/restart.ninja" "restart.ninja"     runEx "-frestart.ninja" "--sleep"     assertExists "restart.txt"++    createDirectoryRecursive "directory1"+    createDirectoryRecursive "directory2"+    run "-f../../src/Test/Ninja/allow_directory.ninja"      when False $ do         -- currently fails because Shake doesn't match Ninja here

@@ -0,0 +1,6 @@+rule create+    command = echo 1 > $out++build root: phony || allow_directory.txt directory1+build allow_directory.txt: create | directory2+default root

@@ -37,14 +37,14 @@ opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tail . breakOn "=") "type=value") ""]  main = testBuildArgs test opt $ \args -> do-    addOracle $ \(T.RandomType _) -> return 42-    addOracle $ \(RandomType _) -> return (-42)+    addOracle $ \(T.RandomType _) -> pure 42+    addOracle $ \(RandomType _) -> pure (-42)     "randomtype.txt" %> \out -> do         a <- askOracle $ T.RandomType $ BinarySentinel ()         b <- askOracle $ RandomType $ BinarySentinel ()         writeFile' out $ show (a,b) -    addOracle $ \b -> return $ not b+    addOracle $ \b -> pure $ not b     "true.txt" %> \out -> writeFile' out . show =<< askOracle False      let add :: forall a . (ShakeValue a, RuleResult a ~ String) => String -> a -> Rules ()@@ -53,7 +53,7 @@                 liftIO $ appendFile ".log" "."                 writeFile' out =<< askOracle key             forM_ [val | Define nam val <- args, nam == name] $ \val ->-                addOracle $ \(_ :: a) -> return val+                addOracle $ \(_ :: a) -> pure val     add "string" ""     add "unit" ()     add "int" (0 :: Int)

@@ -29,8 +29,8 @@     phony "papplicative" $ do         need ["papplicative_1"]         need ["papplicative_2"]-        let ensureReturn = return ()-        ensureReturn -- should work even though we have a return+        let ensureReturn = pure ()+        ensureReturn -- should work even though we have a pure         need ["papplicative_3"]      "pseparate_*" %> \out -> do@@ -41,7 +41,7 @@      phony "pseparate" $ do         need ["pseparate_1"]-        liftIO $ return ()+        liftIO $ pure ()         need ["pseparate_2"]      sem <- liftIO $ newQSemN 0@@ -77,10 +77,13 @@         writeFile' "parallel" $ show peak      "parallels" %> \out -> do-        xs <- parallel $ replicate 5 $ parallel $ map return [1..5]+        xs <- parallel $ replicate 5 $ parallel $ map pure [1..5]         writeFile' out $ show xs +    phony "timings" $+        void $ parallel $ map (liftIO . sleep) [1, 2, 0, 1] + test build = do     build ["clean"]     writeFile "A.txt" "AAA"@@ -106,3 +109,8 @@     assertContents "pseparate.log" "[][]"     build ["papplicative","-j3"]     build ["ptraverse","-j8"]++    build ["timings","-j6"]+    assertTimings build [("timings",4)]+    build ["timings","-j1"]+    assertTimings build [("timings",4)]

@@ -7,7 +7,9 @@ import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad+import System.Time.Extra import Data.Either.Extra+import General.Timing   main = testSimple $ do@@ -23,10 +25,10 @@             runPool deterministic n $ \pool ->                 replicateM_ 5 $                     add pool $ do-                        modifyVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)+                        modifyVar_ var $ \(mx,now) -> pure (max (now+1) mx, now+1)                         -- requires that all tasks get spawned within 0.1s                         sleep 0.1-                        modifyVar_ var $ \(mx,now) -> return (mx,now-1)+                        modifyVar_ var $ \(mx,now) -> pure (mx,now-1)             res <- readVar var             res === (min n 5, 0) @@ -42,7 +44,7 @@                     flip finally (signalBarrier stopped ()) $ do                         signalBarrier started ()                         sleep 10-                        modifyVar_ good $ const $ return False+                        modifyVar_ good $ const $ pure False         -- note that the pool finishing means we started killing our threads         -- not that they have actually died         mapLeft fromException res === Left (Just Underflow)@@ -60,7 +62,7 @@         -- check high priority stuff runs first         res <- newVar ""         runPool deterministic 1 $ \pool -> do-            let note c = modifyVar_ res $ return . (c:)+            let note c = modifyVar_ res $ pure . (c:)             -- deliberately in a random order             addPool PoolBatch pool $ note 'b'             addPool PoolException pool $ note 'e'@@ -92,3 +94,12 @@             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++    -- benchmark for testing thread performance, see https://github.com/ndmitchell/shake/pull/751+    when False $ do+        resetTimings+        withNumCapabilities 4 $ do+            (d, _) <- duration $ runPool False 4 $ \pool ->+                replicateM_ 200000 $ addPool PoolStart pool $ return ()+            print d+            print =<< getTimings

@@ -7,7 +7,7 @@ import System.FilePath  -main = testBuild test $ return ()+main = testBuild test $ pure ()   -- | Given a list of todo times, get out a list of how long is predicted@@ -19,7 +19,7 @@     let resolution = 10000 -- Use resolution to get extra detail on the numbers     let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)     let res = progressReplay $ zip (map (*resolution) [1..]) $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done-    return $ (0/0) : map ((/ resolution) . actualSecs) res+    pure $ (0/0) : map ((/ resolution) . actualSecs) res   test build = do

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-}  module Test.Random(main) where@@ -41,7 +42,7 @@             i <- randomRIO (0, 25)             sleep $ intToDouble i / 100 -    forM_ (map read $ filter (isNothing . asDuration) args) $ \x -> case x of+    forM_ (map read $ filter (isNothing . asDuration) args) $ \case         Want xs -> want $ map (toFile . Output) xs         Logic out srcs -> toFile (Output out) %> \out -> do             res <- fmap (show . Multiple) $ forM srcs $ \src -> do@@ -64,7 +65,7 @@         args <- getArgs         let bound = listToMaybe $ reverse $ mapMaybe asDuration args         time <- offsetTime-        return $ when (isJust bound) $ do+        pure $ when (isJust bound) $ do             now <- time             when (now > fromJust bound) exitSuccess @@ -88,9 +89,9 @@         res <- try_ $ build $ "--exception" : ("-j" ++ show j) : map ((++) "--arg=" . show) (logicBang ++ [Want [i | Logic i _ <- logicBang]])         case res of             Left err-                | "BANG" `isInfixOf` show err -> return () -- error I expected+                | "BANG" `isInfixOf` show err -> pure () -- error I expected                 | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err-            _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt+            _ -> pure () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt         runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]         where             runLogic :: [Int] -> [Logic] -> IO ()@@ -106,7 +107,7 @@                  let value i =                         let ys = head [ys | Logic j ys <- xs, j == i]-                        in Multiple $ flip map ys $ map $ \i -> case i of+                        in Multiple $ flip map ys $ map $ \case                             Input i -> Single $ if i `elem` negated then negate i else i                             Output i -> value i                             Bang -> error "BANG"@@ -122,13 +123,13 @@     i <- randomRIO (0, length xs - 1)     let (before,now:after) = splitAt i xs     now <- f now-    return $ before ++ now : after+    pure $ before ++ now : after     where         f (Logic log xs) = do             i <- randomRIO (0, length xs)             let (before,after) = splitAt i xs-            return $ Logic log $ before ++ [Bang] : after-        f x = return x+            pure $ Logic log $ before ++ [Bang] : after+        f x = pure x   randomLogic :: IO [Logic] -- only Logic constructors@@ -136,7 +137,7 @@     rules <- randomRIO (1,100)     f rules $ map Input inputRange     where-        f 0 _ = return []+        f 0 _ = pure []         f i avail = do             needs <- randomRIO (0,3)             xs <- replicateM needs $ do

@@ -4,6 +4,7 @@ import Development.Shake import Test.Type import Text.Read+import Data.List.Extra import Control.Monad import General.GetOpt @@ -14,7 +15,7 @@  main = testBuildArgs test opts $ \args -> do     let timestamp = concat [x | Timestamp x <- args]-    let p = last $ PatWildcard : [x | Pattern x <- args]+    let p = lastDef PatWildcard [x | Pattern x <- args]     want ["a.txt"]     pat p "a.txt" $ \out -> do         src <- readFile' "b.txt"

@@ -3,7 +3,7 @@  import Development.Shake import Test.Type-import Data.List+import Data.List.Extra import System.FilePath import Control.Exception.Extra import System.Time.Extra@@ -56,7 +56,7 @@         res <- newThrottle "throttle" 2 0.4         phony "throttle" $ need ["t_file1.1","t_file2.1","t_file3.2","t_file4.1","t_file5.2"]         "t_*.*" %> \out -> do-            withResource res (read $ drop 1 $ takeExtension out) $+            withResource res (read $ drop1 $ takeExtension out) $                 when (takeBaseName out == "t_file3") $ liftIO $ sleep 0.2             writeFile' out "" 

@@ -29,7 +29,7 @@      ghcPkg <- addOracleHash $ \GhcPkg{} -> do         Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"-        return $ words out+        pure $ words out      ghcFlags <- addOracleHash $ \GhcFlags{} ->         map ("-package=" ++) <$> readFileLines ".pkgs"

@@ -25,7 +25,7 @@      ghcPkg <- addOracleHash $ \GhcPkg{} -> do         Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"-        return $ words out+        pure $ words out      ghcFlags <- addOracleHash $ \GhcFlags{} ->         map ("-package=" ++) <$> readFileLines ".pkgs"

@@ -13,22 +13,22 @@  rules :: Rules () rules = do-    withTargetDocs "A phony target" $ phony "phony1" $ return ()+    withTargetDocs "A phony target" $ phony "phony1" $ pure () -    "file1" %> \_ -> return ()-    ["file2", "file3"] |%> \_ -> return ()-    ["file4", "file5"] &%> \_ -> return ()+    "file1" %> \_ -> pure ()+    ["file2", "file3"] |%> \_ -> pure ()+    ["file4", "file5"] &%> \_ -> pure () -    "file6" %> \_ -> return ()-    ["file7", "file8"] |%> \_ -> return ()-    ["file9", "file10"] &%> \_ -> return ()+    "file6" %> \_ -> pure ()+    ["file7", "file8"] |%> \_ -> pure ()+    ["file9", "file10"] &%> \_ -> pure () -    withTargetDocs "Builds something really good" $ phony "phony2" $ return ()+    withTargetDocs "Builds something really good" $ phony "phony2" $ pure ()     withTargetDocs "bad docs" $ do-        withTargetDocs "a great file" $ "file11" %> \_ -> return ()-        withTargetDocs "awesome files" $ ["file12", "file13"] &%> \_ -> return ()-        phony "Foo" $ return ()-        withoutTargets $ phony "Bar" $ return ()+        withTargetDocs "a great file" $ "file11" %> \_ -> pure ()+        withTargetDocs "awesome files" $ ["file12", "file13"] &%> \_ -> pure ()+        phony "Foo" $ pure ()+        withoutTargets $ phony "Bar" $ pure ()      addHelpSuffix "Don't Panic"     addHelpSuffix "Know where your towel is"

@@ -33,14 +33,14 @@     isAnswer 1 $ withCleanup $ \cleanup -> do         allocateThread cleanup finish         sleep 0.1-        return 1+        pure 1     finished 1      putStrLn "## allocateThread, main finishes first"     isAnswer 1 $ withCleanup $ \cleanup -> do         allocateThread cleanup $ (unpause >> sleep 100) `finally` finish         pause-        return 1+        pure 1     finished 1      putStrLn "## allocateThread, spawned throws an exception"@@ -54,16 +54,16 @@         allocateThread cleanup $ (unpause >> sleep 100) `finally` finish         pause         throw Overflow-        return 1+        pure 1     finished 1      putStrLn "## withThreadsBoth, both succeed"-    isAnswer (2,3) $ withThreadsBoth (return 2) (return 3)+    isAnswer (2,3) $ withThreadsBoth (pure 2) (pure 3)      putStrLn "## withThreadsBoth, left fails"-    isException Overflow $ withThreadsBoth (pause >> throw Overflow >> return 1) ((unpause >> return 3) `finally` finish)+    isException Overflow $ withThreadsBoth (pause >> throw Overflow >> pure 1) ((unpause >> pure 3) `finally` finish)     finished 1      putStrLn "## withThreadsBoth, right fails"-    isException Overflow $ withThreadsBoth ((unpause >> return 3) `finally` finish) (pause >> throw Overflow >> return 1)+    isException Overflow $ withThreadsBoth ((unpause >> pure 3) `finally` finish) (pause >> throw Overflow >> pure 1)     finished 1

@@ -22,7 +22,7 @@                     | takeExtension x == ".a" = takeBaseName x </> "lib" ++ x                     | otherwise = error $ "Unknown extension, " ++ x             x <- fromMaybe (error $ "Missing config key, " ++ key) <$> getConfig key-            return $ map f $ words x+            pure $ map f $ words x      (\x -> x -<.> exe == x) ?> \out -> do         os <- objects "" $ takeBaseName out <.> "exe"

@@ -10,6 +10,7 @@     assertBool, assertBoolIO, assertException, assertExceptionAfter,     assertContents, assertContentsUnordered, assertContentsWords, assertContentsInfix,     assertExists, assertMissing,+    assertTimings,     (===),     (&?%>),     Pat(PatWildcard), pat,@@ -27,7 +28,8 @@  import Control.Exception.Extra import Control.Monad.Extra-import Data.List+import Data.List.Extra+import Text.Read(readMaybe) import Data.Maybe import Data.Either import Data.Typeable@@ -56,10 +58,10 @@ testBuild f g = testBuildArgs f [] (const g)  testSimple :: IO () -> IO () -> IO ()-testSimple act = testBuild (const act) (return ())+testSimple act = testBuild (const act) (pure ())  testNone :: IO () -> IO ()-testNone _ = return ()+testNone _ = pure ()  shakenEx     :: Bool@@ -74,7 +76,7 @@     name:args <- getArgs     putStrLn $ "## BUILD " ++ unwords (name:args)     let forward = "--forward" `elem` args-    args <- return $ delete "--forward" args+    args <- pure $ delete "--forward" args     let out = "output/" ++ name ++ "/"     let change = if not reenter then withCurrentDirectory out else id     let clean = do@@ -103,9 +105,9 @@          args -> change $ do             t <- tracker-            opts <- return shakeOptions{shakeFiles = "."}+            opts <- pure shakeOptions{shakeFiles = "."}             cwd <- getCurrentDirectory-            opts <- return $ if forward then forwardOptions opts{shakeLintInside=[""]} else opts+            opts <- pure $ if forward then forwardOptions opts{shakeLintInside=[""]} else opts                 {shakeLint = Just t                 ,shakeLintInside = [cwd </> ".." </> ".."]                 ,shakeLintIgnore = [".cabal-sandbox/**",".stack-work/**","../../.stack-work/**"]}@@ -118,13 +120,13 @@                     let (extra1, extra2) = partitionEithers extra                     when (Clean `elem` extra1) clean                     when (Sleep `elem` extra1) sleeper-                    so <- return $ if UsePredicate `notElem` extra1 then so else+                    so <- pure $ if UsePredicate `notElem` extra1 then so else                         so{shakeExtra = addShakeExtra UsePredicateYes $ shakeExtra so}                     if "clean" `elem` files then-                        clean >> return Nothing-                    else return $ Just $ (,) so $ do+                        clean >> pure Nothing+                    else pure $ Just $ (,) so $ do                         -- if you have passed sleep, suppress the "no actions" warning-                        when (Sleep `elem` extra1) $ action $ return ()+                        when (Sleep `elem` extra1) $ action $ pure ()                         rules extra2 files  data Flags@@ -149,12 +151,12 @@ tracker :: IO Lint tracker = do     fsatrace <- findExecutable $ "fsatrace" <.> exe-    return $ if isJust fsatrace then LintFSATrace else LintBasic+    pure $ if isJust fsatrace then LintFSATrace else LintBasic  hasTracker :: IO Bool hasTracker = do     t <- tracker-    return $ t == LintFSATrace+    pure $ t == LintFSATrace  assertFail :: String -> IO a assertFail msg = error $ "ASSERTION FAILED: " ++ msg@@ -186,7 +188,7 @@     t <- timeout n act     case t of         Nothing -> assertFail $ "Expected to complete within " ++ show n ++ " seconds, but did not"-        Just v -> return v+        Just v -> pure v  assertContents :: FilePath -> String -> IO () assertContents file want = do@@ -221,6 +223,23 @@ assertException :: [String] -> IO a -> IO () assertException = assertExceptionAfter id +assertTimings :: ([String] -> IO ()) -> [(String, Seconds)] -> IO ()+assertTimings build expect = do+    build ["--report=report.json","--no-build"]+    src <- IO.readFile' "report.json"+    let f ('[':'\"':xs)+            | (name,_:',':xs) <- break (== '\"') xs+            , num <- takeWhile (`notElem` ",]") xs+            , Just num <- readMaybe num+            = (name, num :: Double)+        f x = error $ "Failed to parse JSON output in assertTimings, " ++ show x+    let got = [f x | x <- map drop1 $ lines src, x /= ""]+    forM_ expect $ \(name, val) ->+        case lookup name got of+            Nothing -> assertFail $ "Couldn't find key " ++ show name ++ " in profiling output"+            Just v -> assertBool (v >= val && v < (val + 1)) $ "Unexpected value, got " ++ show v ++ ", hoping for " ++ show val ++ " (+ 1 sec)"++ defaultTest :: ([String] -> IO ()) -> IO () defaultTest build = do     build ["--abbrev=output=$OUT","-j3","--report"]@@ -241,14 +260,14 @@     mtimes <- forM [1..2] $ \i -> fmap fst $ duration $ do         writeFile file $ show i         let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $-                        getFileInfo $ fileNameFromString file+                        getFileInfo False $ fileNameFromString file         t1 <- time         flip loopM 0 $ \j -> do             writeFile file $ show (i,j)             t2 <- time-            return $ if t1 == t2 then Left $ j+1 else Right ()+            pure $ if t1 == t2 then Left $ j+1 else Right ()     putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum' mtimes * 1000)) ++ "ms"-    return $ sleep $ min 1 $ maximum' mtimes * 2+    pure $ sleep $ min 1 $ maximum' mtimes * 2   removeFilesRandom :: FilePath -> IO Int@@ -257,7 +276,7 @@     n <- randomRIO (0,length files)     rs <- replicateM (length files) (randomIO :: IO Double)     mapM_ (removeFile . snd) $ sort $ zip rs files-    return n+    pure n   getDirectoryContentsRecursive :: FilePath -> IO [FilePath]@@ -265,7 +284,7 @@     xs <- IO.getDirectoryContents dir     (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ "." `isPrefixOf` x]     rest <- concatMapM getDirectoryContentsRecursive dirs-    return $ files++rest+    pure $ files++rest   copyDirectoryChanged :: FilePath -> FilePath -> IO ()@@ -309,7 +328,7 @@     get = do         x <- get         let want = show (typeRep (Proxy :: Proxy a))-        if x == want then return $ BinarySentinel () else+        if x == want then pure $ BinarySentinel () else             error $ "BinarySentinel failed, got " ++ show x ++ " but wanted " ++ show want  newtype RandomType = RandomType (BinarySentinel ())

@@ -4,6 +4,7 @@ import Development.Shake import Development.Shake.FilePath import Test.Type+import Data.List.Extra import General.GetOpt import Control.Monad import GHC.IO.Encoding@@ -23,7 +24,7 @@     ,Option "" ["want"] (ReqArg (Right . Want) "") ""]  main = testBuildArgs test opts $ \xs -> do-    let pre = last $ "" : [decode x | Prefix x <- xs :: [Arg]]+    let pre = lastDef "" [decode x | Prefix x <- xs :: [Arg]]     want [decode x | Want x <- xs]      pre ++ "dir/*" %> \out -> do

@@ -19,7 +19,7 @@             b <- getVerbosity             c <- quietly getVerbosity             d <- fmap shakeVerbosity getShakeOptions-            return [a,b,c,d]+            pure [a,b,c,d]         z <- getVerbosity         writeFile' out $ unwords $ map show $ [x] ++ ys ++ [z] 

@@ -5,6 +5,7 @@ import Development.Shake import Development.Shake.Classes import General.GetOpt+import Data.List.Extra import Text.Read import Test.Type @@ -21,12 +22,12 @@      "foo.txt" %> \file -> liftIO $ appendFile file "x" -    let ver = head $ [x | Ver x <- opts] ++ [0]+    let ver = headDef 0 [x | Ver x <- opts]     versioned ver $ "ver.txt" %> \out -> liftIO $ appendFile out $ show ver      versioned ver $ addOracleCache $ \(Oracle ()) -> do         liftIO $ appendFile "oracle.in" $ show ver-        return $ ver `mod` 2+        pure $ ver `mod` 2     "oracle.txt" %> \out -> do         v <- askOracle $ Oracle ()         liftIO $ appendFile out $ show v