packages feed

shake 0.17.7 → 0.17.8

raw patch · 15 files changed

+415/−138 lines, 15 filesdep ~base

Dependency ranges changed: base

Files

CHANGES.txt view
@@ -1,5 +1,11 @@ Changelog for Shake (* = breaking change) +0.17.8, released 2019-04-02+    Eliminate a corner case of losing exception messages+    Make FSATrace available as a result type+    Commands which have AutoDeps aren't also linted+    #278, add StdoutTrim - like Stdout, but with trim applied+    #659, require base >= 4.8 0.17.7, released 2019-03-18     Add back -B as an alias for --rebuild     Make --help say which other options have changed
README.md view
@@ -1,4 +1,4 @@-# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/shake/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/shake) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/shake/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/shake)+# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Linux build status](https://img.shields.io/travis/ndmitchell/shake/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/shake) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/shake/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/shake)  Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com).
docs/Manual.md view
@@ -198,7 +198,7 @@      files <- getDirectoryFiles "src" ["//*.c","//*.cpp"] -The `getDirectoryFiles` operation is tracked by the build system, so if the files in a directory changes the rule will rebuild in the next run. You should only use `getDirectoryFiles` on source files, not files that are generated by the build system, otherwise the results will change while you are running the build and the build may be inconsistent.+The `getDirectoryFiles` operation is tracked by the build system, so if the files in a directory change the rule will rebuild in the next run. You should only use `getDirectoryFiles` on source files, not files that are generated by the build system, otherwise the results will change while you are running the build and the build may be inconsistent.  #### List manipulations @@ -321,7 +321,7 @@  #### Lint -Shake features a built in "lint" features to check the build system is well formed. To run use `build --lint`. You are likely to catch more lint violations if you first `build clean`. Sadly, lint does _not_ catch missing dependencies. However, it does catch:+Shake features a built in "lint" feature to check the build system is well formed. To run use `build --lint`. You are likely to catch more lint violations if you first `build clean`. Sadly, lint does _not_ catch missing dependencies. However, it does catch:  * Changing the current directory, typically with `setCurrentDirectory`. You should never change the current directory within the build system as multiple rules running at the same time share the current directory. You can still run `cmd_` calls in different directories using the `Cwd` argument. * Outputs that change after Shake has built them. The usual cause of this error is if the rule for `foo` also writes to the file `bar`, despite `bar` having a different rule producing it.@@ -357,7 +357,7 @@  Now the variable `code` is bound to the exit code, while `out` and `err` are bound to the stdout and stderr streams. If `ExitCode` is not requested then any non-zero return value will raise an error. -Both `cmd_` and `cmd` also takes additional parameters to control how the command is run. As an example:+Both `cmd_` and `cmd` also take additional parameters to control how the command is run. As an example:      cmd_ Shell (Cwd "temp") "pwd"
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.17.7+version:            0.17.8 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -80,7 +80,7 @@     default-language: Haskell2010     hs-source-dirs:   src     build-depends:-        base >= 4.5,+        base >= 4.8,         binary,         bytestring,         deepseq >= 1.1,@@ -360,6 +360,7 @@         Development.Ninja.Lexer         Development.Ninja.Parse         Development.Ninja.Type+        Development.Rattle         Development.Shake         Development.Shake.Classes         Development.Shake.Command@@ -465,6 +466,7 @@         Test.Pool         Test.Progress         Test.Random+        Test.Rattle         Test.Rebuild         Test.Resources         Test.Self
+ src/Development/Rattle.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, RecordWildCards, TupleSections #-}++module Development.Rattle(+    rattle,+    cmd,+    parallel,+    liftIO+    ) where++import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Control.Monad.Extra+import System.IO.Error+import System.IO.Extra+import Control.Exception.Extra+import qualified Development.Shake.Command as C+import qualified Data.HashMap.Strict as Map+import Data.IORef+import System.Directory+import Data.List.Extra+import Data.Maybe+import Data.Time+import Data.Tuple.Extra+++newtype Run a = Run {unRun :: ReaderT (IORef S) IO a}+    deriving (Functor, Applicative, Monad, MonadIO)++newtype T = T Int -- timestamps+    deriving (Enum,Eq,Ord,Show)++data S = S+    {timestamp :: T -- the timestamp I am on+    -- ,running :: [Args] -- things that are running now+    ,finished :: [(T, T, Cmd)] -- people who have finished+    ,history :: [Cmd] -- what I ran last time around+    } deriving Show++getTimestamp :: Run T+getTimestamp = do+    ref <- Run ask+    liftIO $ atomicModifyIORef' ref $ \s -> (s{timestamp = succ $ timestamp s}, timestamp s)++getHistory :: Run [Cmd]+getHistory = do+    ref <- Run ask+    liftIO $ history <$> readIORef ref++addExecuted :: (T, T, Cmd) -> Run ()+addExecuted x = do+    ref <- Run ask+    liftIO $ atomicModifyIORef' ref $ \s -> (s{finished = x : finished s}, ())++parallel :: [Run a] -> Run [a]+parallel = sequence++type Args = [String]++cmd :: Args -> Run ()+cmd args = do+    start <- getTimestamp+    history <- getHistory+    skip <- liftIO $ flip firstJustM history $ \cmd@Cmd{..} -> do+        let conds = (return $ args == cmdArgs) :+                    [(== time) <$> getModTime file | (file,time) <- cmdRead ++ cmdWrite]+        ifM (andM conds) (return $ Just cmd) (return Nothing)+    cmd <- case skip of+        Just cmd -> return cmd+        Nothing -> do+            liftIO $ putStrLn $ unwords $ "#" : args+            xs :: [C.FSATrace] <- liftIO $ C.cmd args+            let (reads, writes) = both (nubOrd . concat) $ unzip $ map fsaRW xs+            let f xs = liftIO $ forM xs $ \x -> (x,) <$> getModTime x+            -- explicitly add back in the program beacuse of https://github.com/jacereda/fsatrace/issues/19+            prog <- liftIO $ case args of+                prog:_ -> findExecutable prog+                _ -> return Nothing+            reads <- f $ maybeToList prog ++ reads+            writes <- f writes+            return $ Cmd args reads writes+    stop <- getTimestamp+    addExecuted (start, stop, cmd)+++getModTime :: FilePath -> IO (Maybe UTCTime)+getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x)++fsaRW :: C.FSATrace -> ([FilePath], [FilePath])+fsaRW (C.FSAWrite x) = ([], [x])+fsaRW (C.FSARead x) = ([x], [])+fsaRW (C.FSADelete x) = ([], [x])+fsaRW (C.FSAMove x y) = ([], [x,y])+fsaRW (C.FSAQuery x) = ([x], [])+fsaRW (C.FSATouch x) = ([], [x])++data Cmd = Cmd+    {cmdArgs :: Args+    ,cmdRead :: [(FilePath, Maybe UTCTime)]+    ,cmdWrite :: [(FilePath, Maybe UTCTime)]+    } deriving (Show, Read)+++-- | Given an Action to run, and a list of previous commands that got run, run it again+rattle :: Run a -> IO a+rattle act = do+    history <- ifM (doesFileExist ".rattle") (map read . lines <$> readFile' ".rattle") (return [])+    ref <- newIORef $ S (T 0) [] history+    res <- flip runReaderT ref $ unRun act+    cmds <- finished <$> readIORef ref+    checkHazards cmds+    writeFile ".rattle" $ unlines $ reverse $ map (show . thd3) cmds+    return res++-- | You get a write/write hazard if two separate commands write to the same file.+--   You get a read/write hazard if there was a read of a file before a write.+checkHazards :: [(T, T, Cmd)] -> IO ()+checkHazards xs = do+    let writeWrite = Map.filter (\args -> length args > 1) $ Map.fromListWith (++) [(fst x, [cmdArgs]) | (_,_,Cmd{..}) <- xs, x <- cmdWrite]+    unless (Map.null writeWrite) $+        fail $ "Write/write: " ++ show writeWrite++    let lastWrite = Map.fromList [(fst x, (end, cmdArgs)) | (_,end,Cmd{..}) <- xs, x <- cmdWrite]+    let readWrite = [x | (start,_,Cmd{..}) <- xs, x <- cmdRead, Just (t, args) <- [Map.lookup (fst x) lastWrite], t >= start, args /= cmdArgs]+    unless (null readWrite) $+        fail $ "Read/write: " ++ show readWrite
src/Development/Shake.hs view
@@ -70,7 +70,7 @@     Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,     -- * Running commands     command, command_, cmd, cmd_, unit,-    Stdout(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..),+    Stdout(..), StdoutTrim(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..), FSATrace(..),     CmdResult, CmdString, CmdOption(..),     addPath, addEnv,     -- * Explicit parallelism
src/Development/Shake/Command.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, TypeOperators, ScopedTypeVariables, NamedFieldPuns #-}-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable, RecordWildCards #-}   -- | This module provides functions for calling command line programs, primarily@@ -13,7 +13,7 @@ --   You should only need to import this module if you are using the 'cmd' function in the 'IO' monad. module Development.Shake.Command(     command, command_, cmd, cmd_, unit, CmdArgument(..), CmdArguments(..), IsCmdArgument(..), (:->),-    Stdout(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..),+    Stdout(..), StdoutTrim(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..), FSATrace(..),     CmdResult, CmdString, CmdOption(..),     addPath, addEnv,     ) where@@ -25,8 +25,10 @@ import Data.Either.Extra import Data.List.Extra import Data.Maybe+import Data.Data import Data.Semigroup (Semigroup) import System.Directory+import qualified System.IO.Extra as IO import System.Environment import System.Exit import System.IO.Extra hiding (withTempFile, withTempDir)@@ -34,7 +36,7 @@ import System.Info.Extra import System.Time.Extra import System.IO.Unsafe(unsafeInterleaveIO)-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import General.Extra import General.Process@@ -43,7 +45,6 @@ import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Core.Types hiding (Result) import Development.Shake.FilePath-import Development.Shake.Internal.FilePattern import Development.Shake.Internal.Options import Development.Shake.Internal.Rules.File import Development.Shake.Internal.Derived@@ -88,8 +89,19 @@     return $ Env $ extra ++ filter (\(a,_) -> a `notElem` map fst extra) args  -data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving Eq+data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving (Eq,Show) +strTrim :: Str -> Str+strTrim (Str x) = Str $ trim x+strTrim (BS x) = BS $ fst $ BS.spanEnd isSpace $ BS.dropWhile isSpace x+strTrim (LBS x) = LBS $ trimEnd $ LBS.dropWhile isSpace x+    where+        trimEnd x = case LBS.uncons x of+            Just (c, x2) | isSpace c -> trimEnd x2+            _ -> x+strTrim Unit = Unit++ data Result     = ResultStdout Str     | ResultStderr Str@@ -98,26 +110,152 @@     | ResultTime Double     | ResultLine String     | ResultProcess PID-      deriving Eq+    | ResultFSATrace [FSATrace]+      deriving (Eq,Show)  data PID = PID0 | PID ProcessHandle instance Eq PID where _ == _ = True+instance Show PID where show PID0 = "PID0"; show _ = "PID" +data Params = Params+    {funcName :: String+    ,opts :: [CmdOption]+    ,results :: [Result]+    ,prog :: String+    ,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+ ---------------------------------------------------------------------+-- DEAL WITH Shell++removeOptionShell+    :: MonadTempDir m+    => Params -- ^ Given the parameter+    -> (Params -> m a) -- ^ Call with the revised params, program name and command line+    -> m a+removeOptionShell params@Params{..} call+    | 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}++        prog <- liftIO $ if isFSATrace params then copyFSABinary prog else return prog+        let realCmdline = unwords $ prog : args+        if not isWindows then+            call params{prog = "/bin/sh", args = ["-c",realCmdline]}+        else+            -- On Windows the Haskell behaviour isn't that clean and is very fragile, so we try and do better.+            runWithTempDir $ \dir -> do+                let file = dir </> "s.bat"+                writeFile' file realCmdline+                call params{prog = "cmd.exe", args = ["/d/q/c",file]}+    | otherwise = call params+++---------------------------------------------------------------------+-- DEAL WITH FSATrace++isFSATrace :: Params -> Bool+isFSATrace Params{..} = ResultFSATrace [] `elem` 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+    | otherwise = do+        progFull <- findExecutable prog+        case progFull of+            Just x | any (`isPrefixOf` x) ["/bin/","/usr/","/sbin/"] -> do+                -- The file is one of the ones we can't trace, so we make a copy of it in $TMP and run that+                -- We deliberately don't clean up this directory, since otherwise we spend all our time copying binaries over+                tmpdir <- getTemporaryDirectory+                let fake = tmpdir </> "fsatrace-fakes" ++ x -- x is absolute, so must use +++                unlessM (doesFileExist fake) $ do+                    createDirectoryRecursive $ takeDirectory fake+                    copyFile x fake+                return fake+            _ -> return prog++removeOptionFSATrace+    :: MonadTempDir m+    => Params -- ^ Given the parameter+    -> (Params -> m [Result]) -- ^ Call with the revised params, program name and command line+    -> m [Result]+removeOptionFSATrace params@Params{..} call+    | not $ isFSATrace params = call params+    | 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+        fail "Asyncronous process execution combined with FSATrace is not support"+    | otherwise = runWithTempDir $ \dir -> do+        let file = dir </> "fsatrace.txt"+        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+    where+        fsaFlags = fromMaybe "rwmdqt" fsaOptions+        fsaOptions = last $ Nothing : [Just x | FSAOptions x <- opts]++        fsaParams file Params{..} = do+            prog <- copyFSABinary prog+            return params{prog = "fsatrace", args = fsaFlags : file : "--" : prog : args }+++isFSAOptions FSAOptions{} = True+isFSAOptions _ = False++addFSAOptions :: String -> [CmdOption] -> [CmdOption]+addFSAOptions x opts | any isFSAOptions opts = map f opts+    where f (FSAOptions y) = FSAOptions $ nubOrd $ y ++ x+          f x = x+addFSAOptions x opts = FSAOptions x : opts+++-- | 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+    = -- | Writing to a file+      FSAWrite FilePath+    | -- | Reading from a file+      FSARead FilePath+    | -- | Deleting a file+      FSADelete FilePath+    | -- | Moving, arguments destination, then source+      FSAMove FilePath FilePath+    | -- | Querying\/stat on a file+      FSAQuery FilePath+    | -- | Touching a file+      FSATouch FilePath+      deriving (Show,Eq,Ord,Data,Typeable)+++-- | 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+++--------------------------------------------------------------------- -- ACTION EXPLICIT OPERATION --- | Given explicit operations, apply the advance ones, like skip/trace/track/autodep-commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]-commandExplicit funcName oopts results prog args = do-    ShakeOptions-        {shakeCommandOptions,shakeRunCommands-        ,shakeLint,shakeLintInside,shakeLintIgnore} <- getShakeOptions-    let fopts = shakeCommandOptions ++ oopts-    let useShell = Shell `elem` fopts-    let useLint = shakeLint == Just LintFSATrace-    let useAutoDeps = AutoDeps `elem` fopts-    let opts = filter (/= Shell) fopts+-- | Given explicit operations, apply the Action ones, like skip/trace/track/autodep+commandExplicitAction :: Params -> Action [Result]+commandExplicitAction oparams = do+    ShakeOptions{shakeCommandOptions,shakeRunCommands,shakeLint,shakeLintInside} <- getShakeOptions+    params@Params{..} <- return $ oparams{opts = shakeCommandOptions ++ opts oparams}      let skipper act = if null results && not shakeRunCommands then return [] else act @@ -125,124 +263,57 @@             let cwd = listToMaybe $ reverse [x | Cwd x <- opts]             putLoud $                 maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++-                if useShell then unwords $ prog : args else showCommandForUser2 prog args+                last (showCommandForUser2 prog args : [x | UserCommand x <- opts])             verb <- getVerbosity             -- run quietly to supress the tracer (don't want to print twice)             (if verb >= Loud then quietly else id) act -    let dropExe x = if x -<.> exe == x then dropExtension x else x-    let tracer = case reverse [x | Traced x <- opts] of-            "":_ -> liftIO-            msg:_ -> traced msg-            _ -> traced $ dropExe $ takeFileName $ if useShell then fst (word1 prog) else prog+    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]+            if msg == "" then liftIO act else traced msg act +    let async = ResultProcess PID0 `elem` results     let tracker act-            | useLint = fsatrace act-            | useAutoDeps = autodeps act-            | useShell = shelled act-            | otherwise = act prog args+            | AutoDeps `elem` opts = if async then fail "Can't use AutoDeps and asyncronous execution" else autodeps act+            | shakeLint == Just LintFSATrace && not async = fsalint act+            | otherwise = act params -        shelled = runShell (unwords $ prog : args)+        autodeps act = do+            ResultFSATrace pxs : res <- act params{opts = addFSAOptions "r" opts, results = ResultFSATrace [] : results}+            xs <- liftIO $ filterM doesFileExist [x | FSARead x <- pxs]+            cwd <- liftIO getCurrentDirectory+            unsafeAllowApply . need =<< fixPaths cwd xs+            return res -        -- Want to turn this path (which is absolute) into a relative path (if at all possible)-        -- and check it is covered by shakeLintInside, but isn't covered by shakeLintIngore-        fixPaths cwd xs = do+        fixPaths cwd xs = liftIO $ do             xs <- return $ map toStandard xs             xs <- return $ filter (\x -> any (`isPrefixOf` x) shakeLintInside) xs-            mapMaybeM (makeRelativeEx cwd) xs--        fsaCmd act opts file-            | isMac = fsaCmdMac act opts file-            | useShell = runShell (unwords $ prog : args) $ \prog args -> act "fsatrace" $ opts : file : "--" : prog : args-            | otherwise = act "fsatrace" $ opts : file : "--" : prog : args--        fsaCmdMac act opts file = do-            let fakeExe e = liftIO $ do-                    me <- findExecutable e-                    case me of-                        Just re -> do-                            let isSystem = any (`isPrefixOf` re) [ "/bin"-                                                                 , "/usr"-                                                                 , "/sbin"-                                                                 ]-                            if isSystem-                                then do-                                    tmpdir <- getTemporaryDirectory-                                    let fake = tmpdir ++ "fsatrace-fakes" ++ re-                                    unlessM (doesFileExist fake) $ do-                                        createDirectoryRecursive $ takeDirectory fake-                                        copyFile re fake-                                    return fake-                                else return re-                        Nothing -> return e-            fexe <- fakeExe prog-            if useShell-                then do-                    fsh <- fakeExe "/bin/sh"-                    act "fsatrace" $ opts : file : "--" : fsh : "-c" : [unwords $ fexe : args]-                else act "fsatrace" $ opts : file : "--" : fexe : args+            mapM (\x -> fromMaybe x <$> makeRelativeEx cwd x) xs -        fsatrace act = withTempFile $ \file -> do-            res <- fsaCmd act "rwm" file-            xs <- liftIO $ parseFSAT <$> readFileUTF8' file-            cwd <- liftIO getCurrentDirectory-            let reader (FSATRead x) = Just x; reader _ = Nothing-                writer (FSATWrite x) = Just x; writer (FSATMove x _) = Just x; writer _ = Nothing+        fsalint act = do+            ResultFSATrace xs : res <- act params{opts = addFSAOptions "rwm" opts, results = ResultFSATrace [] : results}+            let reader (FSARead x) = Just x; reader _ = Nothing+                writer (FSAWrite x) = Just x; writer (FSAMove x _) = Just x; writer _ = Nothing                 existing f = liftIO . filterM doesFileExist . nubOrd . mapMaybe f-            rs <- existing reader xs-            ws <- existing writer xs-            reads  <- liftIO $ fixPaths cwd rs-            writes <- liftIO $ fixPaths cwd ws-            when useAutoDeps $ do-                let ignore = (?==*) shakeLintIgnore-                unsafeAllowApply $ needed $ filter (not . ignore) reads-            trackRead reads-            trackWrite writes-            return res--        autodeps act = withTempFile $ \file -> do-            res <-  fsaCmd act "r" file-            pxs <- liftIO $ parseFSAT <$> readFileUTF8' file-            xs <- liftIO $ filterM doesFileExist [x | FSATRead x <- pxs]             cwd <- liftIO getCurrentDirectory-            unsafeAllowApply $ need =<< liftIO (fixPaths cwd xs)+            trackRead  =<< fixPaths cwd =<< existing reader xs+            trackWrite =<< fixPaths cwd =<< existing writer xs             return res -    skipper $ tracker $ \prog args -> verboser $ tracer $ commandExplicitIO funcName opts results prog args+    skipper $ tracker $ \params -> verboser $ tracer $ commandExplicitIO params  --- | Given a shell command, call the continuation with the sanitised exec-style arguments-runShell :: String -> (String -> [String] -> Action a) -> Action a-runShell x act | not isWindows = act "/bin/sh" ["-c",x] -- do exactly what Haskell does-runShell x act = withTempDir $ \dir -> do-    let file = dir </> "s.bat"-    writeFile' file x-    act "cmd.exe" ["/d/q/c",file]+defaultTraced :: Params -> String+defaultTraced Params{..} = takeBaseName $ if Shell `elem` opts then fst (word1 prog) else prog  --- | Parse the FSATrace structure-data FSAT-    = FSATWrite FilePath-    | FSATRead FilePath-    | FSATDelete FilePath-    | FSATMove FilePath FilePath-      deriving Show---- | Parse the 'FSAT' entries, ignoring anything you don't understand.-parseFSAT :: String -> [FSAT]-parseFSAT = mapMaybe f . lines-    where f ('w':'|':xs) = Just $ FSATWrite xs-          f ('r':'|':xs) = Just $ FSATRead xs-          f ('d':'|':xs) = Just $ FSATDelete xs-          f ('m':'|':xs) | (xs,'|':ys) <- break (== '|') xs = Just $ FSATMove xs ys-          f _ = Nothing- --------------------------------------------------------------------- -- IO EXPLICIT OPERATION  -- | Given a very explicit set of CmdOption, translate them to a General.Process structure-commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result]-commandExplicitIO funcName opts results prog args = do+commandExplicitIO :: 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             ResultStdout{} -> (True, False)             ResultStderr{} -> (False, True)@@ -256,7 +327,6 @@             StdinBS x -> Just $ SrcBytes x             FileStdin x -> Just $ SrcFile x             _ -> Nothing-    let optShell = Shell `elem` opts     let optBinary = BinaryPipes `elem` opts     let optAsync = ResultProcess PID0 `elem` results     let optTimeout = listToMaybe $ reverse [x | Timeout x <- opts]@@ -266,8 +336,9 @@     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 optRealCommand = showCommandForUser2 prog args+    let optUserCommand = last $ optRealCommand : [x | UserCommand x <- opts] -    let cmdline = showCommandForUser2 prog args     let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; return (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)@@ -278,15 +349,16 @@         fmap unzip3 $ forM results $ \r -> case r of             ResultCode _ -> return ([], [], \_ _ ex -> return $ ResultCode ex)             ResultTime _ -> return ([], [], \dur _ _ -> return $ ResultTime dur)-            ResultLine _ -> return ([], [], \_ _ _ -> return $ ResultLine cmdline)+            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      exceptionBuffer <- newBuffer     po <- resolvePath ProcessOpts-        {poCommand = if optShell then ShellCommand $ unwords $ prog:args else RawCommand prog args+        {poCommand = RawCommand prog args         ,poCwd = optCwd, poEnv = optEnv, poTimeout = optTimeout         ,poStdin = [SrcBytes LBS.empty | optBinary && not (null optStdin)] ++ optStdin         ,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout && not optAsync] ++ concat dStdout@@ -306,7 +378,8 @@                 return $ "Current directory: " ++ v ++ "\n"         fail $             "Development.Shake." ++ funcName ++ ", system command failed\n" ++-            "Command: " ++ cmdline ++ "\n" +++            "Command line: " ++ optRealCommand ++ "\n" +++            (if optRealCommand /= optUserCommand then "Original command line: " ++ optUserCommand ++ "\n" else "") ++             cwd ++             "Exit code: " ++ show (case exit of ExitFailure i -> i; _ -> 0) ++ "\n" ++             if null captured then "Stderr not captured because WithStderr False was used\n"@@ -376,8 +449,15 @@ -- | Collect the @stdout@ of the process. --   If used, the @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout'. --   The value type may be either 'String', or either lazy or strict 'ByteString'.+--+--   Note that most programs end their output with a trailing newline, so calling+--   @ghc --numeric-version@ will result in 'Stdout' of @\"6.8.3\\n\"@. If you want to automatically+--   trim the resulting string, see 'StdoutTrim'. newtype Stdout a = Stdout {fromStdout :: a} +-- | Like 'Stdout' but remove all leading and trailing whitespaces.+newtype StdoutTrim a = StdoutTrim {fromStdoutTrim :: a}+ -- | Collect the @stderr@ of the process. --   If used, the @stderr@ will not be echoed to the terminal, unless you include 'EchoStderr'. --   The value type may be either 'String', or either lazy or strict 'ByteString'.@@ -454,9 +534,15 @@ instance CmdResult CmdTime where     cmdResult = ([ResultTime 0], \[ResultTime x] -> CmdTime x) +instance CmdResult [FSATrace] where+    cmdResult = ([ResultFSATrace []], \[ResultFSATrace x] -> x)+ instance CmdString a => CmdResult (Stdout a) where     cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> Stdout $ b x) +instance CmdString a => CmdResult (StdoutTrim a) where+    cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> StdoutTrim $ b $ strTrim x)+ instance CmdString a => CmdResult (Stderr a) where     cmdResult = let (a,b) = cmdString in ([ResultStderr a], \[ResultStderr x] -> Stderr $ b x) @@ -511,13 +597,13 @@ --   pass @'WithStderr' 'False'@, which causes no streams to be captured by Shake, and certain programs (e.g. @gcc@) --   to detect they are running in a terminal. command :: CmdResult r => [CmdOption] -> String -> [String] -> Action r-command opts x xs = b <$> commandExplicit "command" opts a x xs+command opts x xs = b <$> commandExplicitAction (Params "command" opts a x xs)     where (a,b) = cmdResult  -- | A version of 'command' where you do not require any results, used to avoid errors about being unable --   to deduce 'CmdResult'. command_ :: [CmdOption] -> String -> [String] -> Action ()-command_ opts x xs = void $ commandExplicit "command_" opts [] x xs+command_ opts x xs = void $ commandExplicitAction (Params "command_" opts [] x xs)   ---------------------------------------------------------------------@@ -590,11 +676,11 @@     cmdArguments xs x = cmdArguments $ xs `mappend` toCmdArgument x instance CmdResult r => CmdArguments (Action r) where     cmdArguments (CmdArgument x) = case partitionEithers x of-        (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicit "cmd" opts a x xs+        (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitAction (Params "cmd" opts a x xs)         _ -> error "Error, no executable or arguments given to Development.Shake.cmd" instance CmdResult r => CmdArguments (IO r) where     cmdArguments (CmdArgument x) = case partitionEithers x of-        (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitIO "cmd" opts a x xs+        (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitIO (Params "cmd" opts a x xs)         _ -> error "Error, no executable or arguments given to Development.Shake.cmd" instance CmdArguments CmdArgument where     cmdArguments = id@@ -617,5 +703,5 @@ showCommandForUser2 :: FilePath -> [String] -> String showCommandForUser2 cmd args = unwords $ map (\x -> if safe x then x else showCommandForUser x []) $ cmd : args     where-        safe xs = not (null xs) && not (any bad xs)+        safe xs = xs /= "" && not (any bad xs)         bad x = isSpace x || (x == '\\' && not isWindows) || x `elem` "\"\'"
src/Development/Shake/Internal/CmdOption.hs view
@@ -25,4 +25,6 @@     | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.     | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.     | AutoDeps -- ^ Compute dependencies automatically.+    | 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.       deriving (Eq,Ord,Show,Data,Typeable)
src/Development/Shake/Internal/Core/Monad.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs, ScopedTypeVariables #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections #-}  module Development.Shake.Internal.Core.Monad(     RAW, Capture, runRAW,@@ -11,6 +11,8 @@ import Control.Exception.Extra import Control.Monad.IO.Class import Data.IORef+import Control.Monad+import System.IO import Data.Semigroup import Prelude @@ -65,18 +67,38 @@ type Capture a = (a -> IO ()) -> IO ()  +-- Useful for checking that all continuations are run only once+-- Cannot be enabled for performance reasons and because some of+-- "monad test" deliberately breaks the invariant to check it doesn't go wrong+assertOnceCheck = False++assertOnce :: MonadIO m => String -> (a -> m b) -> IO (a -> m b)+assertOnce msg k+    | not assertOnceCheck = return k+    | otherwise = do+        ref <- liftIO $ newIORef False+        return $ \v -> do+            liftIO $ join $ atomicModifyIORef ref $ \old -> (True,) $ when old $ do+                hPutStrLn stderr "FATAL ERROR: assertOnce failed"+                Prelude.fail $ "assertOnce failed: " ++ msg+            k v+ -- | Run and then call a continuation. runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a) runRAW ro rw m k = do+    k <- assertOnce "runRAW" k     rw <- newIORef rw-    handler <- newIORef undefined+    handler <- newIORef throwIO     writeIORef handler $ \e -> do         -- make sure we never call the error continuation twice         writeIORef handler throwIO         k $ Left e-    goRAW handler ro rw m (k . Right)+    -- If the continuation itself throws an error we need to make sure we+    -- don't end up running it twice (once with its result, once with its own exception)+    goRAW handler ro rw m (\v -> do writeIORef handler throwIO; k $ Right v)         `catch_` \e -> ($ e) =<< readIORef handler + goRAW :: forall ro rw a . IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW ro rw a -> Capture a goRAW handler ro rw = go     where@@ -95,6 +117,7 @@             ModifyRW f -> modifyIORef' rw f >> k ()              CatchRAW m hdl -> do+                hdl <- assertOnce "CatchRAW" hdl                 old <- readIORef handler                 writeIORef handler $ \e -> do                     writeIORef handler old@@ -103,6 +126,7 @@                 go m $ \x -> writeIORef handler old >> k x              CaptureRAW f -> do+                f <- assertOnce "CaptureRAW" f                 old <- readIORef handler                 writeIORef handler throwIO                 f $ \x -> case x of
src/General/Fence.hs view
@@ -6,6 +6,8 @@  import Control.Monad import Control.Monad.IO.Class+import Control.Exception.Extra+import Development.Shake.Internal.Errors import Data.Maybe import Data.Either.Extra import Data.IORef@@ -21,10 +23,10 @@ newFence :: MonadIO m => IO (Fence m a) newFence = Fence <$> newIORef (Left $ const $ return ()) -signalFence :: MonadIO m => Fence m a -> a -> m ()+signalFence :: (Partial, MonadIO m) => Fence m a -> a -> m () signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \x -> case x of     Left queue -> (Right v, queue v)-    Right _ -> error "Shake internal error, signalFence called twice on one Fence"+    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
src/Test.hs view
@@ -47,6 +47,7 @@ import qualified Test.Pool import qualified Test.Progress import qualified Test.Random+import qualified Test.Rattle import qualified Test.Rebuild import qualified Test.Deprioritize import qualified Test.Resources@@ -103,6 +104,7 @@     ,"pool" * Test.Pool.main     ,"progress" * Test.Progress.main     ,"random" * Test.Random.main+    ,"rattle" * Test.Rattle.main     ,"rebuild" * Test.Rebuild.main     ,"resources" * Test.Resources.main     ,"self" * Test.Self.main
src/Test/Command.hs view
@@ -70,6 +70,9 @@         liftIO $ assertException ["BAD"] $ cmd helper "oo eBAD x" (EchoStdout False) (EchoStderr False)         liftIO $ assertException ["MORE"] $ cmd helper "oMORE eBAD x" (WithStdout True) (WithStderr False) (EchoStdout False) (EchoStderr False) +    "throws" ~>+        cmd Shell "not_a_process foo"+     "cwd" !> do         -- FIXME: Linux searches the Cwd argument for the file, Windows searches getCurrentDirectory         helper <- liftIO $ canonicalizePath $ "helper/shake_helper" <.> exe@@ -96,8 +99,8 @@         -- use liftIO since it blows away PATH which makes lint-tracker stop working         Stdout out <- liftIO $ cmd (Env [("FOO","HELLO SHAKE")]) Shell helper "vFOO"         liftIO $ out === "HELLO SHAKE\n"-        Stdout out <- cmd (AddEnv "FOO" "GOODBYE SHAKE") Shell helper "vFOO"-        liftIO $ out === "GOODBYE SHAKE\n"+        StdoutTrim out <- cmd (AddEnv "FOO" "GOODBYE SHAKE") Shell helper "vFOO"+        liftIO $ out === "GOODBYE SHAKE"      "space" !> do         Stdout out <- cmd helper ["oSPACE 1"]@@ -164,6 +167,8 @@     whenM hasTracker $         build ["-j4","--no-lint"]     build ["-j4"]++    assertException ["not_a_process foo"] (build ["throws","--quiet"])   timer :: (CmdResult r, MonadIO m) => (forall r . CmdResult r => m r) -> m r
src/Test/Docs.hs view
@@ -288,7 +288,7 @@ -- | Identifiers that indicate the fragment is a type types :: [String] types = words $-    "MVar IO String FilePath Maybe [String] Char ExitCode Change " +++    "MVar IO String FilePath Maybe [String] FSATrace Char ExitCode 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 @@ whitelist x | null x || isFilePath x || isCmdFlags x || isEnvVar x || isProgram x = True whitelist x | elem x $ words $     "newtype do a q m c x value key os contents clean _make " ++-    ".. /. // \\ //* dir/*/* dir " +++    ".. /. // \\ //* dir/*/* dir [ " ++     "ConstraintKinds TemplateHaskell OverloadedLists OverloadedStrings GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " ++     "Data.List System.Directory Development.Shake.FilePath run " ++     "NoProgress Error src about://tracing " ++
src/Test/Monad.hs view
@@ -89,3 +89,11 @@                 k $ Left $ toException Overflow             flip catchRAW (const $ liftIO $ modifyIORef ref ('y':)) $ throwRAW $ toException Overflow     (===) "xyxyy" =<< readIORef ref++    -- what if we throw an exception inside the continuation of run+    ref <- newIORef 0+    res <- try $ runRAW 1 "test" (return 1) $ \_ -> do+        modifyIORef ref (+1)+        throwIO Overflow+    res === Left Overflow+    (=== 1) =<< readIORef ref
+ src/Test/Rattle.hs view
@@ -0,0 +1,15 @@++module Test.Rattle(main) where++import Development.Rattle+import System.FilePattern.Directory+import Development.Shake.FilePath+import Control.Monad+import Test.Type++main = testSimple $ rattle $ do+    cs <- liftIO $ getDirectoryFiles "." [shakeRoot </> "src/Test/C/*.c"]+    let toO x = takeBaseName x <.> "o"+    forM_ cs $ \c -> cmd ["gcc","-o",toO c,"-c",c]+    cmd $ ["gcc","-o","Main" <.> exe] ++ map toO cs+    cmd ["./Main" <.> exe]