-- can cause a race condition in build systems that write files then read them. Omitting @-threaded@ will
-- still allow your 'cmd' actions to run in parallel, so most build systems will still run in parallel.
--
--- * If you do compile with @-threaded@, pass the options @-qg -qb@ to @-with-rtsopts@
+-- * With GHC 7.8 and later you may add @-threaded@, and pass the options @-qg -qb@ to @-with-rtsopts@
-- to disable parallel garbage collection. Parallel garbage collection in Shake
-- programs typically goes slower than sequential garbage collection, while occupying many cores that
-- could be used for running system commands.
@@ -97,7 +97,7 @@
liftIO, actionOnException, actionFinally,
ShakeException(..),
-- * Configuration
- ShakeOptions(..), Assume(..), Lint(..), Change(..), getShakeOptions,
+ ShakeOptions(..), Assume(..), Lint(..), Change(..), getShakeOptions, getHashedShakeVersion,
-- ** Command line
shakeArgs, shakeArgsWith, shakeOptDescrs,
-- ** Progress reporting
@@ -105,9 +105,9 @@
-- ** Verbosity
Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,
-- * Running commands
- command, command_, cmd,
- Stdout(..), Stderr(..), Exit(..),
- CmdResult, CmdOption(..),
+ command, command_, cmd, unit,
+ Stdout(..), Stderr(..), Stdouterr(..), Exit(..), CmdTime(..), CmdLine(..),
+ CmdResult, CmdString, CmdOption(..),
addPath, addEnv,
-- * Utility functions
copyFile', copyFileChanged,
@@ -116,7 +116,7 @@
removeFiles, removeFilesAfter,
withTempFile, withTempDir,
-- * File rules
- need, want, (%>), (|%>), (?>), phony, (~>),
+ need, want, (%>), (|%>), (?>), phony, (~>), phonys,
(&%>), (&?>),
orderOnly,
FilePattern, (?==), (),
diff --git a/src/Development/Shake/Args.hs b/src/Development/Shake/Args.hs
--- a/src/Development/Shake/Args.hs
+++ b/src/Development/Shake/Args.hs
@@ -35,7 +35,7 @@
-- are 'want'ed (after calling 'withoutActions'). As an example:
--
-- @
--- main = 'shakeArgs' 'shakeOptions'{'shakeFiles' = \"_make/\", 'shakeProgress' = 'progressSimple'} $ do
+-- main = 'shakeArgs' 'shakeOptions'{'shakeFiles' = \"_make\", 'shakeProgress' = 'progressSimple'} $ do
-- 'phony' \"clean\" $ 'Development.Shake.removeFilesAfter' \"_make\" [\"\/\/*\"]
-- 'want' [\"_make\/neil.txt\",\"_make\/emily.txt\"]
-- \"_make\/*.txt\" '%>' \\out ->
@@ -289,6 +289,7 @@
,yes $ Option "r" ["report","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."
,yes $ Option "" ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."
,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."
+ ,yes $ Option "" ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."
,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."
,no $ Option "" ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."
,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."
diff --git a/src/Development/Shake/ByteString.hs b/src/Development/Shake/ByteString.hs
--- a/src/Development/Shake/ByteString.hs
+++ b/src/Development/Shake/ByteString.hs
@@ -15,7 +15,7 @@
wordsMakefile = f . BS.splitWith isSpace
where
f (x:xs) | BS.null x = f xs
- f (x:y:xs) | endsSlash x = BS.concat [BS.init x, BS.singleton ' ', y] : f xs
+ f (x:y:xs) | endsSlash x = f $ BS.concat [BS.init x, BS.singleton ' ', y] : xs
f (x:xs) = x : f xs
f [] = []
diff --git a/src/Development/Shake/Command.hs b/src/Development/Shake/Command.hs
--- a/src/Development/Shake/Command.hs
+++ b/src/Development/Shake/Command.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators, ScopedTypeVariables #-}
-- | This module provides functions for calling command line programs, primarily
-- 'command' and 'cmd'. As a simple example:
@@ -10,39 +10,39 @@
-- The functions from this module are now available directly from "Development.Shake".
-- 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, CmdArguments,
- Stdout(..), Stderr(..), Exit(..),
- CmdResult, CmdOption(..),
+ command, command_, cmd, unit, CmdArguments,
+ Stdout(..), Stderr(..), Stdouterr(..), Exit(..), CmdTime(..), CmdLine(..),
+ CmdResult, CmdString, CmdOption(..),
addPath, addEnv,
) where
import Data.Tuple.Extra
-import Control.Concurrent
-import Control.DeepSeq
-import Control.Exception.Extra as C
+import Control.Applicative
+import Control.Exception.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Either
import Data.List.Extra
import Data.Maybe
-import Foreign.C.Error
import System.Directory
import System.Environment.Extra
import System.Exit
import System.IO.Extra
import System.Process
-import System.Time.Extra
import System.Info.Extra
+import System.Time.Extra
import System.IO.Unsafe(unsafeInterleaveIO)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import General.Process
+import Prelude
import Development.Shake.Core
import Development.Shake.FilePath
import Development.Shake.Types
import Development.Shake.Rules.File
-import GHC.IO.Exception (IOErrorType(..), IOException(..))
-
---------------------------------------------------------------------
-- ACTUAL EXECUTION
@@ -53,12 +53,15 @@
-- Use 'addPath' to modify the @$PATH@ variable, or 'addEnv' to modify other variables.
| Stdin String -- ^ Given as the @stdin@ of the spawned process. By default the @stdin@ is inherited.
| Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly.
- | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default streams use text encoding.
+ | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default 'String' results use text encoding and 'ByteString' results use binary encoding.
| Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable.
| Timeout Double -- ^ Abort the computation after N seconds, will raise a failure exit code.
+ | WithStdout Bool -- ^ Should I include the @stdout@ in the exception if the command fails? Defaults to 'False'.
| WithStderr Bool -- ^ Should I include the @stderr@ in the exception if the command fails? Defaults to 'True'.
- | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required.
- | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required.
+ | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required or you use 'FileStdout'.
+ | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required or you use 'FileStderr'.
+ | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.
+ | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.
deriving (Eq,Ord,Show)
@@ -96,48 +99,55 @@
args <- liftIO getEnvironment
return $ Env $ extra ++ filter (\(a,b) -> a `notElem` map fst extra) args
+data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving Eq
data Result
- = ResultStdout String
- | ResultStderr String
+ = ResultStdout Str
+ | ResultStderr Str
+ | ResultStdouterr Str
| ResultCode ExitCode
+ | ResultTime Double
+ | ResultLine String
deriving Eq
+---------------------------------------------------------------------
+-- ACTION EXPLICIT OPERATION
+
commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]
commandExplicit funcName copts results exe args = do
- opts <- getShakeOptions
- verb <- getVerbosity
+ opts <- getShakeOptions
+ verb <- getVerbosity
- let skipper act = if null results && not (shakeRunCommands opts) then return [] else act
+ let skipper act = if null results && not (shakeRunCommands opts) then return [] else act
- let verboser act = do
- let cwd = listToMaybe $ reverse [x | Cwd x <- copts]
- putLoud $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ saneCommandForUser exe args
- (if verb >= Loud then quietly else id) act
+ let verboser act = do
+ let cwd = listToMaybe $ reverse [x | Cwd x <- copts]
+ putLoud $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ saneCommandForUser exe args
+ (if verb >= Loud then quietly else id) act
- let tracer = case reverse [x | Traced x <- copts] of
- "":_ -> liftIO
- msg:_ -> traced msg
- [] -> traced (takeFileName exe)
+ let tracer = case reverse [x | Traced x <- copts] of
+ "":_ -> liftIO
+ msg:_ -> traced msg
+ [] -> traced (takeFileName exe)
- let tracker act = case shakeLint opts of
- Just LintTracker -> do
- dir <- liftIO $ getTemporaryDirectory
- (file, handle) <- liftIO $ openTempFile dir "shake.lint"
- liftIO $ hClose handle
- dir <- return $ file <.> "dir"
- liftIO $ createDirectory dir
- let cleanup = removeDirectoryRecursive dir >> removeFile file
- flip actionFinally cleanup $ do
- res <- act "tracker" $ "/if":dir:"/c":exe:args
- (read,write) <- liftIO $ trackerFiles dir
- trackRead read
- trackWrite write
- return res
- _ -> act exe args
+ let tracker act = case shakeLint opts of
+ Just LintTracker -> do
+ dir <- liftIO $ getTemporaryDirectory
+ (file, handle) <- liftIO $ openTempFile dir "shake.lint"
+ liftIO $ hClose handle
+ dir <- return $ file <.> "dir"
+ liftIO $ createDirectory dir
+ let cleanup = removeDirectoryRecursive dir >> removeFile file
+ flip actionFinally cleanup $ do
+ res <- act "tracker" $ "/if":dir:"/c":exe:args
+ (read,write) <- liftIO $ trackerFiles dir
+ trackRead read
+ trackWrite write
+ return res
+ _ -> act exe args
- skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName copts results exe args
+ skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName copts results exe args
-- | Given a directory (as passed to tracker /if) report on which files were used for reading/writing
@@ -150,7 +160,7 @@
files <- forM [x | x <- files, takeExtension x == ".tlog", takeExtension (dropExtension $ dropExtension x) == '.':typ] $ \file -> do
xs <- readFileEncoding utf16 $ dir file
return $ filter (not . isPrefixOf "." . takeFileName) . mapMaybe (stripPrefix pre) $ lines xs
- fmap nub $ mapMaybeM correctCase $ nub $ concat files
+ fmap nubOrd $ mapMaybeM correctCase $ nubOrd $ concat files
liftM2 (,) (f "read") (f "write")
@@ -168,141 +178,86 @@
a +/+ b = if null a then b else a ++ "/" ++ b
+---------------------------------------------------------------------
+-- IO EXPLICIT OPERATION
+
commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result]
commandExplicitIO funcName opts results exe args = do
--- BEGIN COPIED
--- Originally from readProcessWithExitCode with as few changes as possible
- cp <- resolvePath cp
- mask $ \restore -> do
- ans <- try_ $ createProcess cp
- (inh, outh, errh, pid) <- case ans of
- Right a -> return a
- Left err -> failure $ show err
-
- let close = maybe (return ()) hClose
- flip onException
- (do close inh; close outh; close errh
- terminateProcess pid; waitForProcess pid) $ restore $ do
-
- -- set pipes to binary if appropriate
- when (BinaryPipes `elem` opts) $ do
- let bin = maybe (return ()) (`hSetBinaryMode` True)
- bin inh; bin outh; bin errh
-
- -- fork off a thread to start consuming stdout
- (out,waitOut,waitOutEcho) <- case outh of
- Nothing -> return ("", return (), return ())
- Just outh -> do
- out <- hGetContents outh
- waitOut <- forkWait $ C.evaluate $ rnf out
- waitOutEcho <- if stdoutEcho
- then forkWait (hPutStr stdout out)
- else return (return ())
- return (out,waitOut,waitOutEcho)
-
- -- fork off a thread to start consuming stderr
- (err,waitErr,waitErrEcho) <- case errh of
- Nothing -> return ("", return (), return ())
- Just errh -> do
- err <- hGetContents errh
- waitErr <- forkWait $ C.evaluate $ rnf err
- waitErrEcho <- if stderrEcho
- then forkWait (hPutStr stderr err)
- else return (return ())
- return (err,waitErr,waitErrEcho)
-
- stopTimeout <- case timeout of
- Nothing -> return $ return ()
- Just t -> do
- thread <- forkIO $ do
- sleep t
- interruptProcessGroupOf pid
- return $ killThread thread
-
- -- now write and flush any input
- let writeInput = do
- case inh of
- Nothing -> return ()
- Just inh -> do
- hPutStr inh input
- hFlush inh
- hClose inh
-
- C.catch writeInput $ \e -> case e of
- IOError { ioe_type = ResourceVanished
- , ioe_errno = Just ioe }
- | Errno ioe == ePIPE -> return ()
- _ -> throwIO e
-
- -- wait on the output
- waitOut
- waitErr
-
- waitOutEcho
- waitErrEcho
+ let (grabStdout, grabStderr) = both or $ unzip $ for results $ \r -> case r of
+ ResultStdout{} -> (True, False)
+ ResultStderr{} -> (False, True)
+ ResultStdouterr{} -> (True, True)
+ _ -> (False, False)
- close outh
- close errh
+ let optCwd = let x = last $ "" : [x | Cwd x <- opts] in if x == "" then Nothing else Just x
+ let optEnv = let x = [x | Env x <- opts] in if null x then Nothing else Just $ concat x
+ let optStdin = concat [x | Stdin x <- opts]
+ let optShell = Shell `elem` opts
+ let optBinary = BinaryPipes `elem` opts
+ 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 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]
- -- wait on the process
- ex <- waitForProcess pid
--- END COPIED
- stopTimeout
+ let cmdline = saneCommandForUser exe 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], Str . concat <$> readBuffer x)
+ buf LBS{} = do x <- newBuffer; return ([DestBytes x], LBS . LBS.fromChunks <$> readBuffer x)
+ buf BS {} = bufLBS (BS . BS.concat . LBS.toChunks)
+ buf Unit = return ([], return Unit)
+ (dStdout, dStderr, resultBuild) :: ([[Destination]], [[Destination]], [Double -> ExitCode -> IO Result]) <-
+ fmap unzip3 $ forM results $ \r -> case r of
+ ResultCode _ -> return ([], [], \dur ex -> return $ ResultCode ex)
+ ResultTime _ -> return ([], [], \dur ex -> return $ ResultTime dur)
+ ResultLine _ -> return ([], [], \dur ex -> return $ ResultLine cmdline)
+ 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)
- when (ResultCode ExitSuccess `notElem` results && ex /= ExitSuccess) $ do
- failure $
- "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++
- (if not stderrThrow then "Stderr not captured because ErrorsWithoutStderr was used"
- else if null err then "Stderr was empty"
- else "Stderr:\n" ++ unlines (dropWhile null $ lines err))
+ exceptionBuffer <- newBuffer
+ po <- resolvePath $ ProcessOpts
+ {poCommand = if optShell then ShellCommand $ unwords $ exe:args else RawCommand exe args
+ ,poCwd = optCwd, poEnv = optEnv, poTimeout = optTimeout
+ ,poStdin = if optBinary then Right $ LBS.pack optStdin else Left optStdin
+ ,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout] ++ concat dStdout
+ ,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr] ++ concat dStderr
+ }
+ res <- try_ $ duration $ process po
- return $ flip map results $ \x -> case x of
- ResultStdout _ -> ResultStdout out
- ResultStderr _ -> ResultStderr err
- ResultCode _ -> ResultCode ex
- where
- failure extra = do
- cwd <- case cwd cp of
+ let failure extra = do
+ cwd <- case optCwd of
Nothing -> return ""
Just v -> do
v <- canonicalizePath v `catch_` const (return v)
return $ "Current directory: " ++ v ++ "\n"
fail $
"Development.Shake." ++ funcName ++ ", system command failed\n" ++
- "Command: " ++ saneCommandForUser exe args ++ "\n" ++
+ "Command: " ++ cmdline ++ "\n" ++
cwd ++ extra
-
- input = last $ "" : [x | Stdin x <- opts]
-
- -- what should I do with these handles
- binary = BinaryPipes `elem` opts
- stdoutEcho = last $ (ResultStdout "" `notElem` results) : [b | EchoStdout b <- opts]
- stdoutCapture = ResultStdout "" `elem` results
- stderrEcho = last $ (ResultStderr "" `notElem` results) : [b | EchoStderr b <- opts]
- stderrThrow = last $ True : [b | WithStderr b <- opts]
- stderrCapture = ResultStderr "" `elem` results || (stderrThrow && ResultCode ExitSuccess `notElem` results)
- timeout = last $ Nothing : [Just x | Timeout x <- opts]
-
- cp0 = (if Shell `elem` opts then shell $ unwords $ exe:args else proc exe args)
- {std_out = if binary || stdoutCapture || not stdoutEcho then CreatePipe else Inherit
- ,std_err = if binary || stderrCapture || not stderrEcho then CreatePipe else Inherit
- ,std_in = if null input then Inherit else CreatePipe
- }
- cp = foldl applyOpt cp0{std_out = CreatePipe, std_err = CreatePipe} opts
- applyOpt :: CreateProcess -> CmdOption -> CreateProcess
- applyOpt o (Cwd x) = o{cwd = if x == "" then Nothing else Just x}
- applyOpt o (Env x) = o{env = Just x}
- applyOpt o Timeout{} = o{create_group = True}
- applyOpt o _ = o
+ case res of
+ Left err -> failure $ show err
+ Right (dur,ex) | ex /= ExitSuccess && ResultCode ExitSuccess `notElem` results -> do
+ exceptionBuffer <- readBuffer exceptionBuffer
+ let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]
+ failure $
+ "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++
+ if null captured then "Stderr not captured because WithStderr False was used\n"
+ else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"
+ else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer)
+ Right (dur,ex) -> mapM (\f -> f dur ex) resultBuild
-- | If the user specifies a custom $PATH, and not Shell, then try and resolve their exe ourselves.
-- Tricky, because on Windows it doesn't look in the $PATH first.
-resolvePath :: CreateProcess -> IO CreateProcess
-resolvePath cp
- | Just e <- env cp
+resolvePath :: ProcessOpts -> IO ProcessOpts
+resolvePath po
+ | Just e <- poEnv po
, Just (_, path) <- find ((==) "PATH" . (if isWindows then upper else id) . fst) e
- , RawCommand prog args <- cmdspec cp
+ , RawCommand prog args <- poCommand po
= do
let progExe = if prog == prog -<.> exe then prog else prog <.> exe
-- use unsafeInterleaveIO to allow laziness to skip the queries we don't use
@@ -319,10 +274,9 @@
| Just old <- old, Just old2 <- old2, equalFilePath old old2 -> True -- I could predict last time
| otherwise -> False
return $ case new of
- Just new | switch -> cp{cmdspec = RawCommand new args}
- _ -> cp
-resolvePath cp = do
- return cp
+ Just new | switch -> po{poCommand = RawCommand new args}
+ _ -> po
+resolvePath po = return po
findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath)
@@ -330,14 +284,6 @@
ifM (doesFileExist s) (return $ Just s) (return Nothing)
--- Copied from System.Process
-forkWait :: IO a -> IO (IO a)
-forkWait a = do
- res <- newEmptyMVar
- _ <- mask $ \restore -> forkIO $ try_ (restore a) >>= putMVar res
- return (takeMVar res >>= either throwIO return)
-
-
-- Like System.Process, but tweaked to show less escaping,
-- Relies on relatively detailed internals of showCommandForUser.
saneCommandForUser :: FilePath -> [String] -> String
@@ -351,17 +297,49 @@
-- FIXED ARGUMENT WRAPPER
-- | Collect the @stdout@ of the process.
--- If you are collecting the @stdout@, it will not be echoed to the terminal, unless you include 'EchoStdout'.
-newtype Stdout = Stdout {fromStdout :: String}
+-- 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'.
+newtype Stdout a = Stdout {fromStdout :: a}
-- | Collect the @stderr@ of the process.
--- If you are collecting the @stderr@, it will not be echoed to the terminal, unless you include 'EchoStderr'.
-newtype Stderr = Stderr {fromStderr :: String}
+-- 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'.
+newtype Stderr a = Stderr {fromStderr :: a}
+-- | Collect the @stdout@ and @stderr@ of the process.
+-- If used, the @stderr@ and @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout' and 'EchoStderr'.
+-- The value type may be either 'String', or either lazy or strict 'ByteString'.
+newtype Stdouterr a = Stdouterr {fromStdouterr :: a}
+
-- | Collect the 'ExitCode' of the process.
-- If you do not collect the exit code, any 'ExitFailure' will cause an exception.
newtype Exit = Exit {fromExit :: ExitCode}
+-- | Collect the time taken to execute the process. Can be used in conjunction with 'CmdLine' to
+-- write helper functions that print out the time of a result.
+--
+-- @
+--timer :: ('CmdResult' r, MonadIO m) => (forall r . 'CmdResult' r => m r) -> m r
+--timer act = do
+-- ('CmdTime' t, 'CmdLine' x, r) <- act
+-- liftIO $ putStrLn $ \"Command \" ++ x ++ \" took \" ++ show t ++ \" seconds\"
+-- return r
+--
+--run :: IO ()
+--run = timer $ 'cmd' \"ghc --version\"
+-- @
+newtype CmdTime = CmdTime {fromCmdTime :: Double}
+
+-- | Collect the command line used for the process. This command line will be approximate -
+-- suitable for user diagnostics, but not for direct execution.
+newtype CmdLine = CmdLine {fromCmdLine :: String}
+
+class CmdString a where cmdString :: (Str, Str -> a)
+instance CmdString () where cmdString = (Unit, \Unit -> ())
+instance CmdString String where cmdString = (Str "", \(Str x) -> x)
+instance CmdString BS.ByteString where cmdString = (BS BS.empty, \(BS x) -> x)
+instance CmdString LBS.ByteString where cmdString = (LBS LBS.empty, \(LBS x) -> x)
+
-- | A class for specifying what results you want to collect from a process.
-- Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those.
class CmdResult a where
@@ -375,12 +353,21 @@
instance CmdResult ExitCode where
cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> x)
-instance CmdResult Stdout where
- cmdResult = ([ResultStdout ""], \[ResultStdout x] -> Stdout x)
+instance CmdResult CmdLine where
+ cmdResult = ([ResultLine ""], \[ResultLine x] -> CmdLine x)
-instance CmdResult Stderr where
- cmdResult = ([ResultStderr ""], \[ResultStderr x] -> Stderr x)
+instance CmdResult CmdTime where
+ cmdResult = ([ResultTime 0], \[ResultTime x] -> CmdTime 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 (Stderr a) where
+ cmdResult = let (a,b) = cmdString in ([ResultStderr a], \[ResultStderr x] -> Stderr $ b x)
+
+instance CmdString a => CmdResult (Stdouterr a) where
+ cmdResult = let (a,b) = cmdString in ([ResultStdouterr a], \[ResultStdouterr x] -> Stdouterr $ b x)
+
instance CmdResult () where
cmdResult = ([], \[] -> ())
@@ -394,7 +381,13 @@
instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where
cmdResult = cmdResultWith $ \(a,(b,c)) -> (a,b,c)
+instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4) => CmdResult (x1,x2,x3,x4) where
+ cmdResult = cmdResultWith $ \(a,(b,c,d)) -> (a,b,c,d)
+instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4, CmdResult x5) => CmdResult (x1,x2,x3,x4,x5) where
+ cmdResult = cmdResultWith $ \(a,(b,c,d,e)) -> (a,b,c,d,e)
+
+
-- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files
-- that are used by the command.
--
@@ -446,6 +439,7 @@
--
-- @
-- () <- 'cmd' \"gcc -c myfile.c\" -- compile a file, throwing an exception on failure
+-- 'unit' $ 'cmd' \"gcc -c myfile.c\" -- alternative to () <- binding.
-- 'Exit' c <- 'cmd' \"gcc -c\" [myfile] -- run a command, recording the exit code
-- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\" -- run a command, recording the exit code and error output
-- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\" -- run a command, recording the output
@@ -455,7 +449,8 @@
-- When passing file arguments we use @[myfile]@ so that if the @myfile@ variable contains spaces they are properly escaped.
--
-- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being
--- unable to deduce 'CmdResult'. To avoid this error, bind the result to @()@, or include a type signature.
+-- unable to deduce 'CmdResult'. To avoid this error, bind the result to @()@, or include a type signature, or use
+-- the 'unit' function.
--
-- The 'cmd' command can also be run in the 'IO' monad, but then 'Traced' is ignored and command lines are not echoed.
cmd :: CmdArguments args => args :-> Action r
@@ -476,7 +471,6 @@
class Arg a where arg :: a -> [Either CmdOption String]
instance Arg String where arg = map Right . words
instance Arg [String] where arg = map Right
-instance Arg (Maybe String) where arg = map Right . maybe [] words
instance Arg CmdOption where arg = return . Left
instance Arg [CmdOption] where arg = map Left
-instance Arg (Maybe CmdOption) where arg = map Left . maybeToList
+instance Arg a => Arg (Maybe a) where arg = maybe [] arg
diff --git a/src/Development/Shake/Config.hs b/src/Development/Shake/Config.hs
--- a/src/Development/Shake/Config.hs
+++ b/src/Development/Shake/Config.hs
@@ -32,6 +32,7 @@
import Control.Applicative
import Data.Tuple.Extra
import Data.List
+import Prelude
-- | Read a config file, returning a list of the variables and their bindings.
diff --git a/src/Development/Shake/Core.hs b/src/Development/Shake/Core.hs
--- a/src/Development/Shake/Core.hs
+++ b/src/Development/Shake/Core.hs
@@ -19,11 +19,9 @@
newCache, newCacheIO,
unsafeExtraThread,
-- Internal stuff
- rulesIO, runAfter
+ rulesIO, runAfter, unsafeIgnoreDependencies,
) where
-import Prelude(); import General.Prelude
-
import Control.Exception.Extra
import Control.Applicative
import Data.Tuple.Extra
@@ -42,6 +40,8 @@
import System.Directory
import System.IO.Extra
import System.Time.Extra
+import Data.Monoid
+import System.IO.Unsafe
import Development.Shake.Classes
import Development.Shake.Pool
@@ -58,6 +58,7 @@
import General.Concurrent
import General.Cleanup
import General.String
+import Prelude
---------------------------------------------------------------------
@@ -77,6 +78,78 @@
-- | Define a pair of types that can be used by Shake rules.
-- To import all the type classes required see "Development.Shake.Classes".
+--
+-- A 'Rule' instance for a class of artifacts (e.g. /files/) provides:
+--
+-- * How to identify individual artifacts, given by the @key@ type, e.g. with file names.
+--
+-- * How to describe the state of an artifact, given by the @value@ type, e.g. the file modification time.
+--
+-- * A way to compare two states of the same individual artifact, with 'equalValue' returning either
+-- 'EqualCheap' or 'NotEqual'.
+--
+-- * A way to query the current state of an artifact, with 'storedValue' returning the current state,
+-- or 'Nothing' if there is no current state (e.g. the file does not exist).
+--
+-- Checking if an artifact needs to be built consists of comparing two @value@s
+-- of the same @key@ with 'equalValue'. The first value is obtained by applying
+-- 'storedValue' to the @key@ and the second is the value stored in the build
+-- database after the last successful build.
+--
+-- As an example, below is a simplified rule for building files, where files are identified
+-- by a 'FilePath' and their state is identified by a hash of their contents
+-- (the builtin functions 'Development.Shake.need' and 'Development.Shake.%>'
+-- provide a similar rule).
+--
+-- @
+--newtype File = File FilePath deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+--newtype Modtime = Modtime Double deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+--getFileModtime file = ...
+--
+--instance Rule File Modtime where
+-- storedValue _ (File x) = do
+-- exists <- System.Directory.doesFileExist x
+-- if exists then Just \<$\> getFileModtime x else return Nothing
+-- equalValue _ _ t1 t2 =
+-- if t1 == t2 then EqualCheap else NotEqual
+-- @
+--
+-- This example instance means:
+--
+-- * A value of type @File@ uniquely identifies a generated file.
+--
+-- * A value of type @Modtime@ will be used to check if a file is up-to-date.
+--
+-- It is important to distinguish 'Rule' instances from actual /rules/. 'Rule'
+-- instances are one component required for the creation of rules.
+-- Actual /rules/ are functions from a @key@ to an 'Action'; they are
+-- added to 'Rules' using the 'rule' function.
+--
+-- A rule can be created for the instance above with:
+--
+-- @
+-- -- Compile foo files; for every foo output file there must be a
+-- -- single input file named \"filename.foo\".
+-- compileFoo :: 'Rules' ()
+-- compileFoo = 'rule' (Just . compile)
+-- where
+-- compile :: File -> 'Action' Modtime
+-- compile (File outputFile) = do
+-- -- figure out the name of the input file
+-- let inputFile = outputFile '<.>' \"foo\"
+-- 'unit' $ 'Development.Shake.cmd' \"fooCC\" inputFile outputFile
+-- -- return the (new) file modtime of the output file:
+-- getFileModtime outputFile
+-- @
+--
+-- /Note:/ In this example, the timestamps of the input files are never
+-- used, let alone compared to the timestamps of the ouput files.
+-- Dependencies between output and input files are /not/ expressed by
+-- 'Rule' instances. Dependencies are created automatically by 'apply'.
+--
+-- For rules whose values are not stored externally,
+-- 'storedValue' should return 'Just' with a sentinel value
+-- and 'equalValue' should always return 'EqualCheap' for that sentinel.
class (
#if __GLASGOW_HASKELL__ >= 704
ShakeValue key, ShakeValue value
@@ -89,8 +162,7 @@
-- | /[Required]/ Retrieve the @value@ associated with a @key@, if available.
--
-- As an example for filenames/timestamps, if the file exists you should return 'Just'
- -- the timestamp, but otherwise return 'Nothing'. For rules whose values are not
- -- stored externally, 'storedValue' should return 'Nothing'.
+ -- the timestamp, but otherwise return 'Nothing'.
storedValue :: ShakeOptions -> key -> IO (Maybe value)
-- | /[Optional]/ Equality check, with a notion of how expensive the check was.
@@ -136,7 +208,7 @@
mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2)
where f (k, v1, xs) (_, v2, ys)
| v1 == v2 = (k, v1, xs ++ ys)
- | otherwise = errorIncompatibleRules k v1 v2
+ | otherwise = unsafePerformIO $ errorIncompatibleRules k v1 v2
instance Monoid a => Monoid (Rules a) where
mempty = return mempty
@@ -237,8 +309,8 @@
execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of
[r]:_ -> r
- rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)
- where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs]
+ rs -> liftIO $ errorMultipleRulesMatch (typeKey k) (show k) (length rs)
+ where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs]
sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest
sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
@@ -253,9 +325,9 @@
Nothing -> NotEqual
Just RuleInfo{..} -> equal k v1 v2
-runExecute :: Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value
+runExecute :: MonadIO m => Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value
runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of
- Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing -- Not sure if this is even possible, but best be safe
+ Nothing -> liftIO $ errorNoRuleToBuildType tk (Just $ show k) Nothing
Just RuleInfo{..} -> execute k
@@ -452,10 +524,10 @@
tv = typeOf (err "apply type" :: value)
Global{..} <- Action getRO
block <- Action $ getsRW localBlockApply
- whenJust block $ errorNoApply tk (fmap show $ listToMaybe ks)
+ whenJust block $ liftIO . errorNoApply tk (fmap show $ listToMaybe ks)
case Map.lookup tk globalRules of
- Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv)
- Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv
+ Nothing -> liftIO $ errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv)
+ Just RuleInfo{resultType=tv2} | tv /= tv2 -> liftIO $ errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv
_ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks
@@ -831,3 +903,12 @@
res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act
liftIO stop
captureRAW $ \continue -> (if isLeft res then addPoolPriority else addPool) globalPool $ continue res
+
+
+-- | Ignore any dependencies added by an action.
+unsafeIgnoreDependencies :: Action a -> Action a
+unsafeIgnoreDependencies act = Action $ do
+ pre <- getsRW localDepends
+ res <- fromAction act
+ modifyRW $ \s -> s{localDepends=pre}
+ return res
diff --git a/src/Development/Shake/Database.hs b/src/Development/Shake/Database.hs
--- a/src/Development/Shake/Database.hs
+++ b/src/Development/Shake/Database.hs
@@ -12,8 +12,6 @@
toReport, checkValid, listLive
) where
-import Prelude(); import General.Prelude
-
import Development.Shake.Classes
import General.Binary
import Development.Shake.Pool
@@ -38,6 +36,8 @@
import Data.Maybe
import Data.List
import System.Time.Extra
+import Data.Monoid
+import Prelude
type Map = Map.HashMap
@@ -277,7 +277,8 @@
return ans
case ans of
Ready r -> do
- diagnostic $ "result " ++ atom k ++ " = " ++ atom (result r)
+ diagnostic $ "result " ++ atom k ++ " = "++ atom (result r) ++
+ " " ++ (if built r == changed r then "(changed)" else "(unchanged)")
journal i (k, Loaded r) -- leave the DB lock before appending
Error _ -> do
diagnostic $ "result " ++ atom k ++ " = error"
@@ -287,7 +288,7 @@
reply $ case res of
Left err -> Error err
Right (v,deps,(doubleToFloat -> execution),traces) ->
- let c | Just r <- r, result r == v = changed r
+ let c | Just r <- r, equal k (result r) v /= NotEqual = changed r
| otherwise = step
in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..}
diff --git a/src/Development/Shake/Derived.hs b/src/Development/Shake/Derived.hs
--- a/src/Development/Shake/Derived.hs
+++ b/src/Development/Shake/Derived.hs
@@ -4,7 +4,8 @@
copyFile', copyFileChanged,
readFile', readFileLines,
writeFile', writeFileLines, writeFileChanged,
- withTempFile, withTempDir
+ withTempFile, withTempDir,
+ getHashedShakeVersion
) where
import Control.Monad.Extra
@@ -19,6 +20,28 @@
import Development.Shake.FilePath
import Development.Shake.Types
import qualified Data.ByteString as BS
+import Data.Hashable
+
+
+-- | Get a checksum of a list of files, suitable for using as `shakeVersion`.
+-- This will trigger a rebuild when the Shake rules defined in any of the files are changed.
+-- For example:
+--
+-- @
+-- main = do
+-- ver <- 'getHashedShakeVersion' [\"Shakefile.hs\"]
+-- 'shakeArgs' 'shakeOptions'{'shakeVersion' = ver} ...
+-- @
+--
+-- To automatically detect the name of the current file, turn on the @TemplateHaskell@
+-- extension and write @$(LitE . StringL . loc_filename \<$\> location)@.
+--
+-- This feature can be turned off during development by passing
+-- the flag @--no-rule-version@ or setting 'shakeVersionIgnore' to 'True'.
+getHashedShakeVersion :: [FilePath] -> IO String
+getHashedShakeVersion files = do
+ hashes <- mapM (fmap (hashWithSalt 0) . BS.readFile) files
+ return $ "hash-" ++ show (hashWithSalt 0 hashes)
checkExitCode :: String -> ExitCode -> Action ()
diff --git a/src/Development/Shake/Errors.hs b/src/Development/Shake/Errors.hs
--- a/src/Development/Shake/Errors.hs
+++ b/src/Development/Shake/Errors.hs
@@ -12,6 +12,7 @@
import Control.Exception
import Data.Typeable
import Data.List
+import General.Extra
err :: String -> a
@@ -28,8 +29,8 @@
,"_apply_" * "askOracle"]
-errorStructured :: String -> [(String, Maybe String)] -> String -> a
-errorStructured msg args hint = error $ unlines $
+errorStructured :: String -> [(String, Maybe String)] -> String -> IO a
+errorStructured msg args hint = errorIO $ unlines $
[msg ++ ":"] ++
[" " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] ++
[hint | hint /= ""]
@@ -39,7 +40,7 @@
-structured :: Bool -> String -> [(String, Maybe String)] -> String -> a
+structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a
structured alt msg args hint = errorStructured (f msg) (map (first f) args) (f hint)
where
f = filter (/= '_') . (if alt then g else id)
@@ -48,7 +49,7 @@
g [] = []
-errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> a
+errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> IO a
errorNoRuleToBuildType tk k tv = structured (specialIsOracleKey tk)
"Build system error - no _rule_ matches the _key_ type"
[("_Key_ type", Just $ show tk)
@@ -56,7 +57,7 @@
,("_Result_ type", fmap show tv)]
"Either you are missing a call to _rule/defaultRule_, or your call to _apply_ has the wrong _key_ type"
-errorRuleTypeMismatch :: TypeRep -> Maybe String -> TypeRep -> TypeRep -> a
+errorRuleTypeMismatch :: TypeRep -> Maybe String -> TypeRep -> TypeRep -> IO a
errorRuleTypeMismatch tk k tvReal tvWant = structured (specialIsOracleKey tk)
"Build system error - _rule_ used at the wrong _result_ type"
[("_Key_ type", Just $ show tk)
@@ -65,7 +66,7 @@
,("Requested _result_ type", Just $ show tvWant)]
"Either the function passed to _rule/defaultRule_ has the wrong _result_ type, or the result of _apply_ is used at the wrong type"
-errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> a
+errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> IO a
errorIncompatibleRules tk tv1 tv2 = if specialIsOracleKey tk then errorDuplicateOracle tk Nothing [tv1,tv2] else errorStructured
"Build system error - rule has multiple result types"
[("Key type", Just $ show tk)
@@ -73,7 +74,7 @@
,("Second result type", Just $ show tv2)]
"A function passed to rule/defaultRule has the wrong result type"
-errorMultipleRulesMatch :: TypeRep -> String -> Int -> a
+errorMultipleRulesMatch :: TypeRep -> String -> Int -> IO a
errorMultipleRulesMatch tk k count
| specialIsOracleKey tk = if count == 0 then err $ "no oracle match for " ++ show tk else errorDuplicateOracle tk (Just k) []
| otherwise = errorStructured
@@ -84,14 +85,14 @@
(if count == 0 then "Either add a rule that produces the above key, or stop requiring the above key"
else "Modify your rules/defaultRules so only one can produce the above key")
-errorRuleRecursion :: Maybe TypeRep -> Maybe String -> a
+errorRuleRecursion :: Maybe TypeRep -> Maybe String -> IO a
errorRuleRecursion tk k = errorStructured -- may involve both rules and oracle, so report as a rule
"Build system error - recursion detected"
[("Key type",fmap show tk)
,("Key value",k)]
"Rules may not be recursive"
-errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> a
+errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> IO a
errorDuplicateOracle tk k tvs = errorStructured
"Build system error - duplicate oracles for the same question type"
([("Question type",Just $ show tk)
@@ -99,7 +100,7 @@
[("Answer type " ++ show i, Just $ show tv) | (i,tv) <- zip [1..] tvs])
"Only one call to addOracle is allowed per question type"
-errorNoApply :: TypeRep -> Maybe String -> String -> a
+errorNoApply :: TypeRep -> Maybe String -> String -> IO a
errorNoApply tk k msg = structured (specialIsOracleKey tk)
"Build system error - cannot currently call _apply_"
[("Reason", Just msg)
diff --git a/src/Development/Shake/FileInfo.hs b/src/Development/Shake/FileInfo.hs
--- a/src/Development/Shake/FileInfo.hs
+++ b/src/Development/Shake/FileInfo.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}
module Development.Shake.FileInfo(
- FileInfo, fileInfoEq, fileInfoNeq, fileInfoVal,
+ FileInfo, fileInfoEq, fileInfoNeq,
FileSize, ModTime, FileHash,
getFileHash, getFileInfo
) where
@@ -36,15 +36,21 @@
import System.Posix.Files.ByteString
#endif
--- A piece of file information, where 0 = Eq to everything, 1 = Eq to nothing, 2+ = normal values
+-- A piece of file information, where 0 and 1 are special (see fileInfo* functions)
newtype FileInfo a = FileInfo Word32
deriving (Typeable,Hashable,Binary,NFData)
+fileInfoEq, fileInfoNeq :: FileInfo a
+fileInfoEq = FileInfo 0 -- Equal to everything
+fileInfoNeq = FileInfo 1 -- Equal to nothing
+
+fileInfo :: Word32 -> FileInfo a
+fileInfo a = FileInfo $ if a > maxBound - 2 then a else a + 2
+
instance Show (FileInfo a) where
show (FileInfo x)
| x == 0 = "EQ"
| x == 1 = "NEQ"
- | x == 2 = "VAL"
| otherwise = "0x" ++ map toUpper (showHex (x-2) "")
instance Eq (FileInfo a) where
@@ -52,14 +58,6 @@
| a == 0 || b == 0 = True
| a == 1 || b == 1 = False
| otherwise = a == b
-
-fileInfoEq, fileInfoNeq, fileInfoVal :: FileInfo a
-fileInfoEq = FileInfo 0
-fileInfoNeq = FileInfo 1
-fileInfoVal = FileInfo 2
-
-fileInfo :: Word32 -> FileInfo a
-fileInfo a = FileInfo $ if a > maxBound - 3 then a else a + 3
data FileInfoHash; type FileHash = FileInfo FileInfoHash
data FileInfoMod ; type ModTime = FileInfo FileInfoMod
diff --git a/src/Development/Shake/FilePattern.hs b/src/Development/Shake/FilePattern.hs
--- a/src/Development/Shake/FilePattern.hs
+++ b/src/Development/Shake/FilePattern.hs
@@ -9,7 +9,6 @@
import System.FilePath(isPathSeparator, pathSeparators, pathSeparator)
import Data.List.Extra
import Data.Tuple.Extra
-import General.Extra
---------------------------------------------------------------------
@@ -150,7 +149,7 @@
directories :: [FilePattern] -> [(FilePath,Bool)]
directories ps = foldl f xs xs
where
- xs = fastNub $ map directories1 ps
+ xs = nubOrd $ map directories1 ps
-- Eliminate anything which is a strict subset
f xs (x,True) = filter (\y -> not $ (x,False) == y || x `isPrefixSlashOf` fst y) xs
diff --git a/src/Development/Shake/Monad.hs b/src/Development/Shake/Monad.hs
--- a/src/Development/Shake/Monad.hs
+++ b/src/Development/Shake/Monad.hs
@@ -8,13 +8,13 @@
unmodifyRW, captureRAW,
) where
-import Prelude(); import General.Prelude
-
import Control.Exception.Extra
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Reader
import Data.IORef
+import Control.Applicative
+import Prelude
data S ro rw = S
diff --git a/src/Development/Shake/Progress.hs b/src/Development/Shake/Progress.hs
--- a/src/Development/Shake/Progress.hs
+++ b/src/Development/Shake/Progress.hs
@@ -8,8 +8,6 @@
ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY
) where
-import Prelude(); import General.Prelude
-
import Control.Applicative
import Data.Tuple.Extra
import Control.Exception.Extra
@@ -31,6 +29,8 @@
import System.IO.Unsafe
import Paths_shake
import System.Time.Extra
+import Data.Monoid
+import Prelude
#ifdef mingw32_HOST_OS
diff --git a/src/Development/Shake/Resource.hs b/src/Development/Shake/Resource.hs
--- a/src/Development/Shake/Resource.hs
+++ b/src/Development/Shake/Resource.hs
@@ -4,8 +4,6 @@
Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource
) where
-import Prelude(); import General.Prelude
-
import Data.Function
import System.IO.Unsafe
import Control.Concurrent.Extra
@@ -14,6 +12,8 @@
import General.Bilist
import Development.Shake.Pool
import System.Time.Extra
+import Data.Monoid
+import Prelude
{-# NOINLINE resourceIds #-}
diff --git a/src/Development/Shake/Rules/Directory.hs b/src/Development/Shake/Rules/Directory.hs
--- a/src/Development/Shake/Rules/Directory.hs
+++ b/src/Development/Shake/Rules/Directory.hs
@@ -23,6 +23,7 @@
import Development.Shake.FilePath
import Development.Shake.FilePattern
import General.Extra
+import Prelude
newtype DoesFileExistQ = DoesFileExistQ FilePath
diff --git a/src/Development/Shake/Rules/File.hs b/src/Development/Shake/Rules/File.hs
--- a/src/Development/Shake/Rules/File.hs
+++ b/src/Development/Shake/Rules/File.hs
@@ -5,7 +5,7 @@
need, needBS, needed, neededBS, want,
trackRead, trackWrite, trackAllow,
defaultRuleFile,
- (%>), (|%>), (?>), phony, (~>),
+ (%>), (|%>), (?>), phony, (~>), phonys,
-- * Internal only
FileQ(..), FileA
) where
@@ -64,10 +64,10 @@
res <- getFileInfo x
case res of
Nothing -> return Nothing
- Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoVal
+ Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoNeq
Just (time,size) -> do
hash <- unsafeInterleaveIO $ getFileHash x
- return $ Just $ FileA (if c == ChangeDigest then fileInfoVal else time) size hash
+ return $ Just $ FileA (if c == ChangeDigest then fileInfoNeq else time) size hash
equalValue ShakeOptions{shakeChange=c} q (FileA x1 x2 x3) (FileA y1 y2 y3) = case c of
ChangeModtime -> bool $ x1 == y1
@@ -132,10 +132,10 @@
pre <- liftIO $ mapM (storedValue opts . FileQ) xs
post <- apply $ map FileQ xs :: Action [FileA]
let bad = [ (x, if isJust a then "File change" else "File created")
- | (x, a, b) <- zip3 xs pre post, Just b /= a]
+ | (x, a, b) <- zip3 xs pre post, maybe NotEqual (\a -> equalValue opts (FileQ x) a b) a == NotEqual]
case bad of
[] -> return ()
- (file,msg):_ -> errorStructured
+ (file,msg):_ -> liftIO $ errorStructured
"Lint checking error - 'needed' file required rebuilding"
[("File", Just $ unpackU file)
,("Error",Just msg)]
@@ -197,8 +197,13 @@
-- in a rule then every execution where that rule is required will rerun both the rule and the phony
-- action.
phony :: String -> Action () -> Rules ()
-phony name act = rule $ \(FileQ x_) -> let x = unpackU x_ in
- if name /= x then Nothing else Just $ do
+phony name act = phonys $ \s -> if s == name then Just act else Nothing
+
+-- | A predicate version of 'phony', return 'Just' with the 'Action' for the matching rules.
+phonys :: (String -> Maybe (Action ())) -> Rules ()
+phonys act = rule $ \(FileQ x_) -> case act $ unpackU x_ of
+ Nothing -> Nothing
+ Just act -> Just $ do
act
return $ FileA fileInfoNeq fileInfoNeq fileInfoNeq
diff --git a/src/Development/Shake/Rules/Files.hs b/src/Development/Shake/Rules/Files.hs
--- a/src/Development/Shake/Rules/Files.hs
+++ b/src/Development/Shake/Rules/Files.hs
@@ -7,6 +7,7 @@
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
+import Data.List.Extra
import System.Directory
import Development.Shake.Core hiding (trackAllow)
@@ -75,7 +76,7 @@
(if all simple ps then id else priority 0.5) $
rule $ \(FilesQ xs_) -> let xs = map (unpackU . fromFileQ) xs_ in
if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do
- liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs
+ liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs
trackAllow xs
act xs
getFileTimes "&%>" xs_
@@ -126,7 +127,7 @@
rule $ \(FilesQ xs_) -> let xs@(x:_) = map (unpackU . fromFileQ) xs_ in
case checkedTest x of
Just ys | ys == xs -> Just $ do
- liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs
+ liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs
act xs
getFileTimes "&?>" xs_
Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys
diff --git a/src/Development/Shake/Rules/Oracle.hs b/src/Development/Shake/Rules/Oracle.hs
--- a/src/Development/Shake/Rules/Oracle.hs
+++ b/src/Development/Shake/Rules/Oracle.hs
@@ -39,7 +39,7 @@
-- @
-- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- rules = do
--- 'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\"
+-- 'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\" :: Action String
-- ... rules ...
-- @
--
diff --git a/src/Development/Shake/Rules/OrderOnly.hs b/src/Development/Shake/Rules/OrderOnly.hs
--- a/src/Development/Shake/Rules/OrderOnly.hs
+++ b/src/Development/Shake/Rules/OrderOnly.hs
@@ -1,38 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
module Development.Shake.Rules.OrderOnly(
- defaultRuleOrderOnly, orderOnly, orderOnlyBS
+ orderOnly, orderOnlyBS
) where
import Development.Shake.Core
-import General.String
-import Development.Shake.ByteString
-import Development.Shake.Classes
import Development.Shake.Rules.File
import qualified Data.ByteString.Char8 as BS
-newtype OrderOnlyQ = OrderOnlyQ BSU
- deriving (Typeable,Eq,Hashable,Binary,NFData)
-
-instance Show OrderOnlyQ where show (OrderOnlyQ x) = unpackU x
-
-newtype OrderOnlyA = OrderOnlyA ()
- deriving (Typeable,Eq,Hashable,Binary,NFData)
-
-instance Show OrderOnlyA where show (OrderOnlyA ()) = "OrderOnly"
-
-
-instance Rule OrderOnlyQ OrderOnlyA where
- storedValue _ (OrderOnlyQ _) = return $ Just $ OrderOnlyA ()
-
-
-defaultRuleOrderOnly :: Rules ()
-defaultRuleOrderOnly = rule $ \(OrderOnlyQ x) -> Just $ do
- needBS [unpackU_ x]
- return $ OrderOnlyA ()
-
-
-- | Define order-only dependencies, these are dependencies that will always
-- be built before continuing, but which aren't dependencies of this action.
-- Mostly useful for defining generated dependencies you think might be real dependencies.
@@ -49,8 +25,8 @@
-- it to be added as a real dependency. If it isn't, then the rule won't rebuild if it changes,
-- and you will have lost some opportunity for parallelism.
orderOnly :: [FilePath] -> Action ()
-orderOnly xs = (apply $ map (OrderOnlyQ . packU_ . filepathNormalise . unpackU_ . packU) xs :: Action [OrderOnlyA]) >> return ()
+orderOnly = unsafeIgnoreDependencies . need
orderOnlyBS :: [BS.ByteString] -> Action ()
-orderOnlyBS xs = (apply $ map (OrderOnlyQ . packU_ . filepathNormalise) xs :: Action [OrderOnlyA]) >> return ()
+orderOnlyBS = unsafeIgnoreDependencies . needBS
diff --git a/src/Development/Shake/Shake.hs b/src/Development/Shake/Shake.hs
--- a/src/Development/Shake/Shake.hs
+++ b/src/Development/Shake/Shake.hs
@@ -8,7 +8,6 @@
import Development.Shake.Rules.Directory
import Development.Shake.Rules.File
-import Development.Shake.Rules.OrderOnly
import Development.Shake.Rules.Rerun
@@ -24,6 +23,5 @@
r
defaultRuleFile
defaultRuleDirectory
- defaultRuleOrderOnly
defaultRuleRerun
return ()
diff --git a/src/Development/Shake/Storage.hs b/src/Development/Shake/Storage.hs
--- a/src/Development/Shake/Storage.hs
+++ b/src/Development/Shake/Storage.hs
@@ -42,11 +42,17 @@
-- THINGS I WANT TO DO ON THE NEXT CHANGE
-- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8
-- * Duration and Time should be stored as number of 1/10000th seconds Int32
-databaseVersion x = "SHAKE-DATABASE-10-" ++ s ++ "\r\n"
+databaseVersion x = "SHAKE-DATABASE-11-" ++ s ++ "\r\n"
where s = tail $ init $ show x -- call show, then take off the leading/trailing quotes
-- ensures we do not get \r or \n in the user portion
+-- Split the version off a file
+splitVersion :: LBS.ByteString -> (LBS.ByteString, LBS.ByteString)
+splitVersion abc = (a `LBS.append` b, c)
+ where (a,bc) = LBS.break (== '\r') abc
+ (b,c) = LBS.splitAt 2 bc
+
withStorage
:: (Show w, Show k, Show v, Eq w, Eq k, Hashable k
,Binary w, BinaryWith w k, BinaryWith w v)
@@ -55,10 +61,10 @@
-> w -- ^ Witness
-> (Map k v -> (k -> v -> IO ()) -> IO a) -- ^ Execute
-> IO a
-withStorage ShakeOptions{shakeVerbosity,shakeOutput,shakeVersion,shakeFlush,shakeFiles,shakeStorageLog} diagnostic witness act = do
- let dbfile = shakeFiles <.> "database"
- bupfile = shakeFiles <.> "bup"
- createDirectoryIfMissing True $ takeDirectory shakeFiles
+withStorage ShakeOptions{shakeVerbosity,shakeOutput,shakeVersion,shakeVersionIgnore,shakeFlush,shakeFiles,shakeStorageLog} diagnostic witness act = do
+ let dbfile = shakeFiles ".shake.database"
+ bupfile = shakeFiles ".shake.backup"
+ createDirectoryIfMissing True shakeFiles
-- complete a partially failed compress
b <- doesFileExist bupfile
@@ -72,17 +78,18 @@
withBinaryFile dbfile ReadWriteMode $ \h -> do
n <- hFileSize h
diagnostic $ "Reading file of size " ++ show n
- src <- LBS.hGet h $ fromInteger n
+ (oldVer,src) <- fmap splitVersion $ LBS.hGet h $ fromInteger n
- if not $ ver `LBS.isPrefixOf` src then do
- unless (LBS.null src) $ do
+ verEqual <- evaluate $ ver == oldVer -- force it so we don't leak the bytestring
+ if not verEqual && not shakeVersionIgnore then do
+ unless (n == 0) $ do
let limit x = let (a,b) = splitAt 200 x in a ++ (if null b then "" else "...")
let disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` "\r\n")
outputErr $ unlines
["Error when reading Shake database - invalid version stamp detected:"
," File: " ++ dbfile
," Expected: " ++ disp (LBS.unpack ver)
- ," Found: " ++ disp (limit $ LBS.unpack src)
+ ," Found: " ++ disp (limit $ LBS.unpack oldVer)
,"All rules will be rebuilt"]
continue h Map.empty
else
@@ -97,14 +104,14 @@
hSeek h AbsoluteSeek 0
i <- hFileSize h
bs <- LBS.hGet h $ fromInteger i
- let cor = shakeFiles <.> "corrupt"
+ let cor = shakeFiles ".shake.corrupt"
LBS.writeFile cor bs
unexpected $ "Backup of corrupted file stored at " ++ cor ++ ", " ++ show i ++ " bytes\n"
-
+
-- exitFailure -- should never happen without external corruption
-- add back to check during random testing
return $ continue h Map.empty) $
- case readChunks $ LBS.drop (LBS.length ver) src of
+ case readChunks src of
([], slop) -> do
when (LBS.length slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"
diagnostic $ "Read 0 chunks, plus " ++ show slop ++ " slop"
@@ -132,7 +139,7 @@
diagnostic $ "Found " ++ show (Map.size mp) ++ " real entries"
-- if mp is null, continue will reset it, so no need to clean up
- if Map.null mp || (ws == witness && Map.size mp * 2 > length xs - 2) then do
+ if verEqual && (Map.null mp || (ws == witness && Map.size mp * 2 > length xs - 2)) then do
-- make sure we reset to before the slop
when (not (Map.null mp) && slop /= 0) $ do
diagnostic $ "Dropping last " ++ show slop ++ " bytes of database (incomplete)"
@@ -157,7 +164,7 @@
where
unexpected x = when shakeStorageLog $ do
t <- getCurrentTime
- appendFile (shakeFiles <.> "storage") $ "\n[" ++ show t ++ "]: " ++ x
+ appendFile (shakeFiles ".shake.storage.log") $ "\n[" ++ show t ++ "]: " ++ x
outputErr x = do
when (shakeVerbosity >= Quiet) $ shakeOutput Quiet x
unexpected x
diff --git a/src/Development/Shake/Types.hs b/src/Development/Shake/Types.hs
--- a/src/Development/Shake/Types.hs
+++ b/src/Development/Shake/Types.hs
@@ -78,13 +78,13 @@
-- because 'Data' cannot be defined for functions.
data ShakeOptions = ShakeOptions
{shakeFiles :: FilePath
- -- ^ Defaults to @.shake@. The prefix of the filename used for storing Shake metadata files.
- -- All metadata files will be named @'shakeFiles'./extension/@, for some @/extension/@.
+ -- ^ Defaults to @.shake@. The directory used for storing Shake metadata files.
+ -- All metadata files will be named @'shakeFiles'\/.shake./file-name/@, for some @/file-name/@.
-- If the 'shakeFiles' directory does not exist it will be created.
,shakeThreads :: Int
-- ^ Defaults to @1@. Maximum number of rules to run in parallel, similar to @make --jobs=/N/@.
-- For many build systems, a number equal to or slightly less than the number of physical processors
- -- works well.
+ -- works well. Use @0@ to match the detected number of processors.
,shakeVersion :: String
-- ^ Defaults to @"1"@. The version number of your build rules.
-- Change the version number to force a complete rebuild, such as when making
@@ -114,7 +114,7 @@
-- ^ Defaults to @[]@. A list of substrings that should be abbreviated in status messages, and their corresponding abbreviation.
-- Commonly used to replace the long paths (e.g. @.make\/i586-linux-gcc\/output@) with an abbreviation (e.g. @$OUT@).
,shakeStorageLog :: Bool
- -- ^ Defaults to 'False'. Write a message to @'shakeFiles'.storage@ whenever a storage event happens which may impact
+ -- ^ Defaults to 'False'. Write a message to @'shakeFiles'\/.shake.storage.log@ whenever a storage event happens which may impact
-- on the current stored progress. Examples include database version number changes, database compaction or corrupt files.
,shakeLineBuffering :: Bool
-- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake.
@@ -131,6 +131,8 @@
,shakeLiveFiles :: [FilePath]
-- ^ Default to '[]'. After the build system completes, write a list of all files which were /live/ in that run,
-- i.e. those which Shake checked were valid or rebuilt. Produces best answers if nothing rebuilds.
+ ,shakeVersionIgnore :: Bool
+ -- ^ Defaults to 'False'. Ignore any differences in 'shakeVersion'.
,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.
@@ -147,7 +149,7 @@
shakeOptions :: ShakeOptions
shakeOptions = ShakeOptions
".shake" 1 "1" Normal False [] Nothing (Just 10) Nothing [] False True False
- True ChangeModtime True []
+ True ChangeModtime True [] False
(const $ return ())
(const $ BS.putStrLn . BS.pack) -- try and output atomically using BS
@@ -155,18 +157,18 @@
["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"
,"shakeLint", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"
,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"
- ,"shakeLiveFiles","shakeProgress", "shakeOutput"]
+ ,"shakeLiveFiles","shakeVersionIgnore","shakeProgress", "shakeOutput"]
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 =
- ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 (fromFunction x18) (fromFunction x19)
+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 =
+ ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 (fromFunction x19) (fromFunction x20)
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) =
+ gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) =
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`
- Function x18 `k` Function x19
- gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide
+ x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k`
+ Function x19 `k` Function x20
+ gunfold k z c = 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
diff --git a/src/General/Bilist.hs b/src/General/Bilist.hs
--- a/src/General/Bilist.hs
+++ b/src/General/Bilist.hs
@@ -3,8 +3,8 @@
Bilist, cons, snoc, uncons, toList, isEmpty
) where
-import Prelude()
-import General.Prelude
+import Data.Monoid
+import Prelude
data Bilist a = Bilist [a] [a]
diff --git a/src/General/Concurrent.hs b/src/General/Concurrent.hs
--- a/src/General/Concurrent.hs
+++ b/src/General/Concurrent.hs
@@ -6,6 +6,7 @@
import Control.Applicative
import Control.Monad
import Data.IORef
+import Prelude
---------------------------------------------------------------------
diff --git a/src/General/Extra.hs b/src/General/Extra.hs
--- a/src/General/Extra.hs
+++ b/src/General/Extra.hs
@@ -3,35 +3,30 @@
module General.Extra(
getProcessorCount,
randomElem,
- fastNub,
- showQuote
+ showQuote,
+ withs,
+ errorIO,
) where
import Control.Exception.Extra
import Data.Char
import Data.List
-import qualified Data.HashSet as Set
import System.Environment.Extra
+import System.IO.Extra
import System.IO.Unsafe
import System.Random
-import Development.Shake.Classes
#if __GLASGOW_HASKELL__ >= 704
import Control.Concurrent
import Foreign.C.Types
#endif
+errorIO :: String -> IO a
+errorIO = throwIO . ErrorCall
+
---------------------------------------------------------------------
-- Data.List
--- | Like 'nub', but the results may be in any order.
-fastNub :: (Eq a, Hashable a) => [a] -> [a]
-fastNub = f Set.empty
- where f seen [] = []
- f seen (x:xs) | x `Set.member` seen = f seen xs
- | otherwise = x : f (Set.insert x seen) xs
-
-
showQuote :: String -> String
showQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""
| otherwise = xs
@@ -62,8 +57,8 @@
case env of
Just s | [(i,"")] <- reads s -> return i
_ -> do
- src <- readFile "/proc/cpuinfo"
- return $ length [() | x <- lines src, "processor" `isPrefixOf` x]
+ src <- readFile' "/proc/cpuinfo"
+ return $! length [() | x <- lines src, "processor" `isPrefixOf` x]
---------------------------------------------------------------------
@@ -73,3 +68,11 @@
randomElem xs = do
i <- randomRIO (0, length xs - 1)
return $ xs !! i
+
+
+---------------------------------------------------------------------
+-- Control.Monad
+
+withs :: [(a -> r) -> r] -> ([a] -> r) -> r
+withs [] act = act []
+withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as
diff --git a/src/General/Prelude.hs b/src/General/Prelude.hs
deleted file mode 100644
--- a/src/General/Prelude.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- for GHC 7.9 compatibility
-
--- | Alternative Prelude which exports more things, so we can be
--- warning-compatible with GHC 7.10.
-module General.Prelude(
- module Prelude,
- Monoid(..), Applicative(..)
- ) where
-
-import Data.Monoid
-import Control.Applicative
diff --git a/src/General/Process.hs b/src/General/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/General/Process.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | A wrapping of createProcess to provide a more flexible interface.
+module General.Process(
+ Buffer, newBuffer, readBuffer,
+ process, ProcessOpts(..), Destination(..)
+ ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception.Extra as C
+import Control.Monad.Extra
+import Data.List.Extra
+import Data.Maybe
+import Foreign.C.Error
+import System.Exit
+import System.IO.Extra
+import System.Info.Extra
+import System.Process
+import System.Time.Extra
+import Data.Unique
+import Data.IORef
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Internal as BS(createAndTrim)
+import qualified Data.ByteString.Lazy as LBS
+import General.Extra
+import Prelude
+
+import GHC.IO.Exception (IOErrorType(..), IOException(..))
+
+---------------------------------------------------------------------
+-- BUFFER ABSTRACTION
+
+data Buffer a = Buffer Unique (IORef [a])
+instance Eq (Buffer a) where Buffer x _ == Buffer y _ = x == y
+instance Ord (Buffer a) where compare (Buffer x _) (Buffer y _) = compare x y
+
+newBuffer :: IO (Buffer a)
+newBuffer = liftM2 Buffer newUnique (newIORef [])
+
+addBuffer :: Buffer a -> a -> IO ()
+addBuffer (Buffer _ ref) x = atomicModifyIORef ref $ \xs -> (x:xs, ())
+
+readBuffer :: Buffer a -> IO [a]
+readBuffer (Buffer _ ref) = reverse <$> readIORef ref
+
+
+---------------------------------------------------------------------
+-- OPTIONS
+
+data Destination
+ = DestEcho
+ | DestFile FilePath
+ | DestString (Buffer String)
+ | DestBytes (Buffer BS.ByteString)
+ deriving (Eq,Ord)
+
+isDestString DestString{} = True; isDestString _ = False
+isDestBytes DestBytes{} = True; isDestBytes _ = False
+
+data ProcessOpts = ProcessOpts
+ {poCommand :: CmdSpec
+ ,poCwd :: Maybe FilePath
+ ,poEnv :: Maybe [(String, String)]
+ ,poTimeout :: Maybe Double
+ ,poStdin :: Either String LBS.ByteString
+ ,poStdout :: [Destination]
+ ,poStderr :: [Destination]
+ }
+
+
+---------------------------------------------------------------------
+-- IMPLEMENTATION
+
+-- | 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 ())
+
+stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
+stdStream file [DestEcho] other = Inherit
+stdStream file [DestFile x] other | other == [DestFile x] || DestFile x `notElem` other = UseHandle $ file x
+stdStream file _ _ = CreatePipe
+
+
+stdIn :: Either String LBS.ByteString -> (StdStream, Handle -> IO ())
+stdIn inp | either null LBS.null inp = (Inherit, const $ return ())
+ | otherwise = (,) CreatePipe $ \h ->
+ void $ tryBool isPipeGone $ do
+ either (hPutStr h) (LBS.hPutStr h) inp
+ hFlush h
+ hClose h
+ where
+ isPipeGone IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe} = Errno ioe == ePIPE
+ isPipeGone _ = False
+
+
+withTimeout :: Maybe Double -> IO () -> IO a -> IO a
+withTimeout Nothing stop go = go
+withTimeout (Just s) stop go = bracket (forkIO $ sleep s >> stop) killThread $ const go
+
+
+cmdSpec :: CmdSpec -> CreateProcess
+cmdSpec (ShellCommand x) = shell x
+cmdSpec (RawCommand x xs) = proc x xs
+
+
+
+forkWait :: IO a -> IO (IO a)
+forkWait a = do
+ res <- newEmptyMVar
+ _ <- mask $ \restore -> forkIO $ try_ (restore a) >>= putMVar res
+ return $ takeMVar res >>= either throwIO return
+
+
+withCreateProcess :: CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+withCreateProcess cp act = mask $ \restore -> do
+ ans@(inh, outh, errh, pid) <- createProcess cp
+ onException (restore $ act ans) $ do
+ mapM_ (`whenJust` hClose) [inh, outh, errh]
+ ignore $ do
+ -- sometimes we fail before the process is valid
+ -- therefore if terminate process fails, skip waiting on the process
+ terminateProcess pid
+ void $ waitForProcess pid
+
+
+-- General approach taken from readProcessWithExitCode
+process :: ProcessOpts -> IO ExitCode
+process po = do
+ (ProcessOpts{..}, flushBuffers) <- optimiseBuffers po
+ let files = nubOrd [x | DestFile x <- poStdout ++ poStderr]
+ withs (map (`withFile` WriteMode) files) $ \handles -> do
+ let fileHandle x = fromJust $ lookup x $ zip files handles
+ let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = isJust poTimeout
+ ,std_in = fst $ stdIn poStdin
+ ,std_out = stdStream fileHandle poStdout poStderr, std_err = stdStream fileHandle poStderr poStdout}
+ withCreateProcess cp $ \(inh, outh, errh, pid) -> do
+ withTimeout poTimeout (interruptProcessGroupOf pid) $ do
+
+ let streams = [(outh, stdout, poStdout) | Just outh <- [outh], CreatePipe <- [std_out cp]] ++
+ [(errh, stderr, poStderr) | Just errh <- [errh], CreatePipe <- [std_err cp]]
+ wait <- forM streams $ \(h, hh, dest) -> do
+ let isTied = not $ poStdout `disjoint` poStderr
+ let isBinary = not $ any isDestString dest && not (any isDestBytes dest)
+ when isTied $ hSetBuffering h LineBuffering
+ when (DestEcho `elem` dest) $ do
+ buf <- hGetBuffering hh
+ case buf of
+ BlockBuffering{} -> return ()
+ _ -> hSetBuffering h buf
+
+ if isBinary then do
+ hSetBinaryMode h True
+ dest <- return $ for dest $ \d -> case d of
+ DestEcho -> BS.hPut hh
+ DestFile x -> BS.hPut (fileHandle x)
+ DestString x -> addBuffer x . (if isWindows then replace "\r\n" "\n" else id) . BS.unpack
+ DestBytes x -> addBuffer x
+ forkWait $ whileM $ do
+ src <- bs_hGetSome h 4096
+ mapM_ ($ src) dest
+ notM $ hIsEOF h
+ else if isTied then do
+ dest <- return $ for dest $ \d -> case d of
+ DestEcho -> hPutStrLn hh
+ DestFile x -> hPutStrLn (fileHandle x)
+ DestString x -> addBuffer x . (++ "\n")
+ forkWait $ whileM $
+ ifM (hIsEOF h) (return False) $ do
+ src <- hGetLine h
+ mapM_ ($ src) dest
+ return True
+ else do
+ src <- hGetContents h
+ wait1 <- forkWait $ C.evaluate $ rnf src
+ waits <- forM dest $ \d -> case d of
+ DestEcho -> forkWait $ hPutStr hh src
+ DestFile x -> forkWait $ hPutStr (fileHandle x) src
+ DestString x -> do addBuffer x src; return $ return ()
+ return $ sequence_ $ wait1 : waits
+
+ whenJust inh $ snd $ stdIn poStdin
+ sequence_ wait
+ flushBuffers
+ res <- waitForProcess pid
+ whenJust outh hClose
+ whenJust errh hClose
+ return res
+
+---------------------------------------------------------------------
+-- COMPATIBILITY
+
+-- available in bytestring-0.9.1.10 and above
+-- implementation copied below
+bs_hGetSome :: Handle -> Int -> IO BS.ByteString
+bs_hGetSome h i = BS.createAndTrim i $ \p -> hGetBufSome h p i
diff --git a/src/Run.hs b/src/Run.hs
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -7,9 +7,15 @@
import Development.Shake
import Development.Shake.FilePath
import General.Timing
+import Data.List.Extra
+import Control.Monad.Extra
+import Control.Exception.Extra
import Data.Maybe
import qualified System.Directory as IO
import System.Console.GetOpt
+import System.Process
+import System.Exit
+import General.Extra
main :: IO ()
@@ -19,17 +25,20 @@
withArgs ("--no-time":args) $
shakeArgsWith shakeOptions{shakeCreationCheck=False} flags $ \opts targets -> do
let tool = listToMaybe [x | Tool x <- opts]
- makefile <- case reverse [x | UseMakefile x <- opts] of
- x:_ -> return x
+ (mode, makefile) <- case reverse [x | UseMakefile x <- opts] of
+ x:_ -> return (modeMakefile x, x)
_ -> findMakefile
- if takeExtension makefile == ".ninja" then
- runNinja makefile targets tool
- else if isJust tool then
- error "--tool flag is not supported without a .ninja Makefile"
- else
- fmap Just $ runMakefile makefile targets
+ case mode of
+ Ninja -> runNinja makefile targets tool
+ _ | isJust tool -> error "--tool flag is not supported without a .ninja Makefile"
+ Exe -> do exitOnFailure =<< rawSystem (toNative makefile) args; return Nothing
+ Haskell -> do exitOnFailure =<< rawSystem "runhaskell" (makefile:args); return Nothing
+ Make -> fmap Just $ runMakefile makefile targets
+exitOnFailure :: ExitCode -> IO ()
+exitOnFailure x = when (x /= ExitSuccess) $ exitWith x
+
data Flag = UseMakefile FilePath
| Tool String
@@ -37,13 +46,23 @@
,Option "t" ["tool"] (ReqArg (Right . Tool) "TOOL") "Ninja-compatible tools."
]
+data Mode = Make | Ninja | Haskell | Exe
-findMakefile :: IO FilePath
+modeMakefile :: FilePath -> Mode
+modeMakefile x | takeExtension x == ".ninja" = Ninja
+ | takeExtension x `elem` [".hs",".lhs"] = Haskell
+ | otherwise = Make
+
+
+findMakefile :: IO (Mode, FilePath)
findMakefile = do
- b <- IO.doesFileExist "makefile"
- if b then return "makefile" else do
- b <- IO.doesFileExist "Makefile"
- if b then return "Makefile" else do
- b <- IO.doesFileExist "build.ninja"
- if b then return "build.ninja" else
- error "Could not find `makefile', `Makefile' or `build.ninja'"
+ let files = [(Exe,".shake" "shake" <.> exe)
+ ,(Haskell,"Shakefile.hs"),(Haskell,"Shakefile.lhs")
+ ,(Make,"makefile"),(Make,"Makefile")
+ ,(Ninja,"build.ninja")]
+ res <- findM (fmap (either (const False) id) . try_ . IO.doesFileExist . snd) files
+ case res of
+ Just x -> return x
+ Nothing -> do
+ let Just (p1,p2) = unsnoc ["`" ++ x ++ "'" | (_,x) <- files]
+ errorIO $ "Could not find " ++ intercalate ", " p1 ++ " or " ++ p2
diff --git a/src/Test.hs b/src/Test.hs
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -46,6 +46,7 @@
import qualified Test.Unicode as Unicode
import qualified Test.Util as Util
import qualified Test.Verbosity as Verbosity
+import qualified Test.Version as Version
import qualified Run
@@ -62,7 +63,7 @@
,"monad" * Monad.main, "pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main
,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main
,"oracle" * Oracle.main, "progress" * Progress.main, "unicode" * Unicode.main, "util" * Util.main
- ,"throttle" * Throttle.main, "verbosity" * Verbosity.main, "tup" * Tup.main]
+ ,"throttle" * Throttle.main, "verbosity" * Verbosity.main, "version" * Version.main, "tup" * Tup.main]
where (*) = (,)
diff --git a/src/Test/Basic.hs b/src/Test/Basic.hs
--- a/src/Test/Basic.hs
+++ b/src/Test/Basic.hs
@@ -28,7 +28,7 @@
src <- readFile' $ obj "zero.txt"
writeFile' out src
- phony "halfclean" $ do
+ phonys $ \x -> if x /= "halfclean" then Nothing else Just $ do
removeFilesAfter (obj "") ["//*e.txt"]
phony "cleaner" $ do
@@ -63,6 +63,9 @@
build ["AB.txt","--sleep"]
assertContents (obj "AB.txt") "AAABBB"
appendFile (obj "A.txt") "aaa"
+ build ["AB.txt"]
+ assertContents (obj "AB.txt") "AAAaaaBBB"
+ removeFile $ obj "AB.txt"
build ["AB.txt"]
assertContents (obj "AB.txt") "AAAaaaBBB"
diff --git a/src/Test/Command.hs b/src/Test/Command.hs
--- a/src/Test/Command.hs
+++ b/src/Test/Command.hs
@@ -1,91 +1,127 @@
+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
module Test.Command(main) where
+import Control.Applicative
import Development.Shake
import Development.Shake.FilePath
import System.Time.Extra
-import Control.Monad
+import Control.Monad.Extra
+import System.Directory
import Test.Type
+import System.Exit
+import Data.Tuple.Extra
+import Data.List.Extra
+import Control.Monad.IO.Class
+import System.Info.Extra
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Prelude
main = shaken test $ \args obj -> do
- want $ map obj args
-
- let a !> b = obj a %> \out -> do alwaysRerun; res <- b; writeFile' out res
+ let helper = [toNative $ obj "shake_helper" <.> exe]
+ let name !> test = do want [name | null args || name `elem` args]
+ name ~> do need [obj "shake_helper" <.> exe]; test
- "ghc-version" !> do
- Stdout stdout <- cmd "ghc --version"
- return stdout
+ let helper_source = unlines
+ ["import Control.Concurrent"
+ ,"import Control.Monad"
+ ,"import System.Directory"
+ ,"import System.Environment"
+ ,"import System.Exit"
+ ,"import System.IO"
+ ,"import qualified Data.ByteString.Lazy.Char8 as LBS"
+ ,"main = do"
+ ," args <- getArgs"
+ ," forM_ args $ \\(a:rg) -> do"
+ ," case a of"
+ ," 'o' -> putStrLn rg"
+ ," 'e' -> hPutStrLn stderr rg"
+ ," 'x' -> exitFailure"
+ ," 'c' -> putStrLn =<< getCurrentDirectory"
+ ," 'v' -> putStrLn =<< getEnv rg"
+ ," 'w' -> threadDelay $ floor $ 1000000 * (read rg :: Double)"
+ ," 'r' -> LBS.putStr $ LBS.replicate (read rg) 'x'"
+ ," hFlush stdout"
+ ," hFlush stderr"
+ ]
- "ghc-random" !> do
- (Stderr stderr, Exit _) <- cmd "ghc --random"
- return stderr
+ obj "shake_helper.hs" %> \out -> do need ["src/Test/Command.hs"]; writeFileChanged out helper_source
+ obj "shake_helper" <.> exe %> \out -> do need [obj "shake_helper.hs"]; cmd (Cwd $ obj "") "ghc --make" "shake_helper.hs -o shake_helper"
- "ghc-random2" !> do
- () <- cmd (EchoStderr False) (Cwd $ obj "") "ghc --random"
- return ""
+ "capture" !> do
+ (Stderr err, Stdout out) <- cmd helper ["ostuff goes here","eother stuff here"]
+ liftIO $ out === "stuff goes here\n"
+ liftIO $ err === "other stuff here\n"
+ Stdouterr out <- cmd helper Shell "o1 w0.2 e2 w0.2 o3"
+ liftIO $ out === "1\n2\n3\n"
- "triple" !> do
- (Exit exit, Stdout stdout, Stderr stderr) <- cmd "ghc --random"
- return $ show (exit, stdout, stderr) -- must force all three parts
+ "failure" !> do
+ (Exit e, Stdout (), Stderr ()) <- cmd helper "oo ee x"
+ when (e == ExitSuccess) $ error "/= ExitSuccess"
+ 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)
- obj "pwd space.hs" %> \out -> writeFileLines out ["import System.Directory","main = putStrLn =<< getCurrentDirectory"]
- "pwd" !> do
- need [obj "pwd space.hs"]
- Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"]
- return out
+ "cwd" !> do
+ -- FIXME: Linux searches the Cwd argument for the file, Windows searches getCurrentDirectory
+ helper <- liftIO $ canonicalizePath $ obj "shake_helper" <.> exe
+ Stdout out <- cmd (Cwd $ obj "") helper "c"
+ liftIO $ (===) (trim out) =<< canonicalizePath (dropTrailingPathSeparator $ obj "")
"timeout" !> do
offset <- liftIO offsetTime
- Exit exit <- cmd (Timeout 2) "ghc -ignore-dot-ghci -e" ["last [1..]"]
+ Exit exit <- cmd (Timeout 2) helper "w20"
t <- liftIO offset
putNormal $ "Timed out in " ++ showDuration t
+ when (exit == ExitSuccess) $ error "== ExitSuccess"
when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t
- return $ show t
"env" !> do
- (Exit _, Stdout out1) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo %FOO%"
- (Exit _, Stdout out2) <- liftIO $ cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo $FOO"
- return $ unlines [out1, out2]
-
- obj "bin/myexe" <.> exe %> \out -> do
- liftIO $ writeFile (obj "myexe.hs") "main = return () :: IO ()"
- cmd "ghc --make" [obj "myexe.hs"] "-o" [out]
-
- "path_" !> do
- need [obj "bin/myexe" <.> exe]
- fmap fromStdout $ cmd "myexe"
+ -- 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"
"path" !> do
- path <- addPath [obj "bin"] []
- () <- cmd $ obj "bin/myexe"
- () <- cmd $ obj "bin/myexe" <.> exe
- () <- cmd path Shell "myexe"
- () <- cmd path "myexe"
- return ""
+ path <- addPath [dropTrailingPathSeparator $ obj ""] []
+ unit $ cmd $ obj "shake_helper"
+ unit $ cmd $ obj "shake_helper" <.> exe
+ unit $ cmd path Shell "shake_helper"
+ unit $ cmd path "shake_helper"
+ "file" !> do
+ let file = obj "file.txt"
+ unit $ cmd helper (FileStdout file) (FileStderr file) (EchoStdout False) (EchoStderr False) (WithStderr False) "ofoo ebar obaz"
+ liftIO $ assertContents file "foo\nbar\nbaz\n"
+ Stderr err <- cmd helper (FileStdout file) (FileStderr file) "ofoo w0.1 ebar w0.1 obaz"
+ liftIO $ err === "bar\n"
+ liftIO $ assertContents file "foo\nbar\nbaz\n"
-test build obj = do
- let crash args parts = assertException parts (build $ "--quiet" : args)
+ "timer" !> do
+ timer $ cmd helper
- build ["ghc-version"]
- assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System"
+ "binary" !> do
+ (Stdout str, Stdout bs) <- cmd BinaryPipes helper "ofoo"
+ 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 ()
- build ["ghc-random"]
- assertContentsInfix (obj "ghc-random") "unrecognised flag"
- assertContentsInfix (obj "ghc-random") "--random"
+ "large" !> do
+ (Stdout (_ :: String), CmdTime t1) <- cmd helper "r10000000"
+ (Stdout (_ :: LBS.ByteString), CmdTime t2) <- cmd helper "r10000000"
+ t3 <- withTempFile $ \file -> fromCmdTime <$> cmd helper "r10000000" (FileStdout file)
+ liftIO $ putStrLn $ "Capturing 10Mb takes: " ++ intercalate ","
+ [s ++ " = " ++ showDuration d | (s,d) <- [("String",t1),("ByteString",t2),("File",t3)]]
- crash ["ghc-random2"] [obj "","unrecognised flag","--random"]
- build ["pwd"]
- assertContentsInfix (obj "pwd") "command"
+test build obj = do
+ -- reduce the overhead by running all the tests in parallel
+ build ["-j4"]
- build ["env","--no-lint"] -- since it blows away the $PATH, which is necessary for lint-tracker
- assertContentsInfix (obj "env") "HELLO SHAKE"
- build ["triple"]
-
- crash ["path_"] ["myexe"]
- build ["path"]
-
- build ["timeout"]
+timer :: (CmdResult r, MonadIO m) => (forall r . CmdResult r => m r) -> m r
+timer act = do
+ (CmdTime t, CmdLine x, r) <- act
+ liftIO $ putStrLn $ "Command " ++ x ++ " took " ++ show t ++ " seconds"
+ return r
diff --git a/src/Test/Digest.hs b/src/Test/Digest.hs
--- a/src/Test/Digest.hs
+++ b/src/Test/Digest.hs
@@ -7,7 +7,7 @@
main = shaken test $ \args obj -> do
- want [obj "Out.txt",obj "Out2.txt"]
+ if null args then want [obj "Out.txt",obj "Out2.txt"] else want $ map obj args
obj "Out.txt" %> \out -> do
txt <- readFile' $ obj "In.txt"
@@ -18,7 +18,11 @@
liftIO $ appendFile out1 txt
liftIO $ appendFile out2 txt
+ "leaf" ~> return ()
+ obj "node1.txt" %> \file -> do need ["leaf"]; writeFile' file "x"
+ obj "node2.txt" %> \file -> do need [obj "node1.txt"]; liftIO $ appendFile file "x"
+
test build obj = do
let outs = take 1 $ map obj ["Out.txt","Out1.txt","Out2.txt"]
let writeOut x = forM_ outs $ \out -> writeFile out x
@@ -76,3 +80,9 @@
writeIn "Q"
build ["--sleep","--digest-and-input"]
assertOut "YXZZQ"
+
+ -- test for #218
+ forM_ [("--digest",1),("--digest-and",1),("--digest-or",2),("--digest-and-input",2),("",2)] $ \(flag,count) -> do
+ writeFile (obj "node2.txt") "y"
+ replicateM_ 2 $ build $ ["node2.txt","--sleep"] ++ [flag | flag /= ""]
+ assertContents (obj "node2.txt") $ 'y' : replicate count 'x'
diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs
--- a/src/Test/Docs.hs
+++ b/src/Test/Docs.hs
@@ -42,17 +42,19 @@
fmap (findCodeMarkdown . lines . noR) $ readFile' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"
else
fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html"
- let f i (Stmt x) | whitelist $ head x = []
+ let f i (Stmt x) | any whitelist x = []
| otherwise = restmt i $ map undefDots $ trims x
f i (Expr x) | takeWhile (not . isSpace) x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x]
| "import " `isPrefixOf` x = [x]
| otherwise = ["expr_" ++ show i ++ " = (" ++ undefDots x2 ++ ")" | let x2 = trim $ dropComment x, not $ whitelist x2]
- code = concat $ zipWith f [1..] (nub src)
+ code = concat $ zipWith f [1..] (nubOrd src)
(imports,rest) = partition ("import " `isPrefixOf`) code
writeFileLines out $
- ["{-# LANGUAGE DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}"
+ ["{-# LANGUAGE DeriveDataTypeable, RankNTypes, MultiParamTypeClasses, ExtendedDefaultRules, GeneralizedNewtypeDeriving #-}"
+ ,"{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}"
,"{-# OPTIONS_GHC -w #-}"
,"module " ++ takeBaseName out ++ "() where"
+ ,"import Control.Applicative"
,"import Control.Concurrent"
,"import Control.Monad"
,"import Data.Char"
@@ -67,7 +69,9 @@
,"import Development.Shake.FilePath"
,"import System.Console.GetOpt"
,"import System.Directory(setCurrentDirectory)"
+ ,"import qualified System.Directory"
,"import System.Exit"
+ ,"import Control.Monad.IO.Class"
,"import System.IO"] ++
["import " ++ replace "_" "." (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++
imports ++
@@ -120,7 +124,7 @@
writeFile' out ""
-data Code = Stmt [String] | Expr String deriving (Show,Eq)
+data Code = Stmt [String] | Expr String deriving (Show,Eq,Ord)
findCodeHaddock :: String -> [Code]
findCodeHaddock x | Just x <- stripPrefix "" x = f (Stmt . shift . lines . strip) "
" x
@@ -148,10 +152,11 @@
trims = reverse . dropWhile (all isSpace) . reverse . dropWhile (all isSpace)
restmt i ("":xs) = restmt i xs
+restmt i (('-':'-':_):xs) = restmt i xs
restmt i (x:xs) | " ?== " `isInfixOf` x || " == " `isInfixOf` x =
zipWith (\j x -> "hack_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] (x:xs)
restmt i (x:xs) |
- not ("let" `isPrefixOf` x) && not ("[" `isPrefixOf` x) && (" = " `isInfixOf` x || " | " `isInfixOf` x) ||
+ not ("let" `isPrefixOf` x) && not ("[" `isPrefixOf` x) && (" = " `isInfixOf` x || " | " `isInfixOf` x || " :: " `isInfixOf` x) ||
"import " `isPrefixOf` x || "infix" `isPrefixOf` x || "instance " `isPrefixOf` x = map f $ x:xs
where f x = if takeWhile (not . isSpace) x `elem` dupes then "_" ++ show i ++ "_" ++ x else x
restmt i xs = ("stmt_" ++ show i ++ " = do") : map (" " ++) xs ++
@@ -201,19 +206,20 @@
whitelist x | elem x $ words $
"newtype do MyFile.txt.digits excel a q m c x value key gcc cl os make contents tar ghc cabal clean _make distcc ghc " ++
".. /./ /.. /../ ./ // \\ ../ //*.c //*.txt //* dir/*/* dir " ++
- "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++
+ "ConstraintKinds TemplateHaskell GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++
"Data.List System.Directory Development.Shake.FilePath main.m run .rot13 " ++
"NoProgress Error src rot13 .js .json .trace about://tracing " ++
".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out build " ++
"/usr/special /usr/special/userbinary $CFLAGS %PATH% -O2 -j8 -j -j1 " ++
"-threaded -rtsopts -I0 Function extension $OUT $C_LINK_FLAGS $PATH xterm $TERM main opts result flagValues argValues " ++
"HEADERS_DIR /path/to/dir CFLAGS let -showincludes -MMD gcc.version linkFlags temp pwd touch code out err " ++
- "_metadata/.database _shake _shake/build ./build.sh build.sh build.bat [out] manual " ++
- "docs/manual _build _build/run ninja depfile build.ninja " ++
+ "_metadata/.shake.database _shake _shake/build ./build.sh build.sh build.bat [out] manual " ++
+ "docs/manual _build _build/run ninja depfile build.ninja ByteString " ++
"Rule CmdResult ShakeValue Monoid Monad Eq Typeable Data " ++ -- work only with constraint kinds
- "@ndm_haskell " ++
+ "@ndm_haskell file-name " ++
"*> "
= True
+whitelist x | "Stdout out" `isInfixOf` x || "Stderr err" `isInfixOf` x = True
whitelist x
| "foo/" `isPrefixOf` x -- path examples
= True
@@ -237,7 +243,7 @@
,"actions"
,"() <- cmd ..."
,"x <- inputs"
- ,"shakeFiles=\"_build/\""
+ ,"shakeFiles=\"_build\""
,"#include \""
,"pattern %> actions = (pattern ?==) ?> actions" -- because it overlaps
,"buildDir = \"_build\""
@@ -262,6 +268,7 @@
,"cabal install shake"
,"shake -j4"
,"cmd \"gcc -o _make/run _build/main.o _build/constants.o\""
+ ,"$(LitE . StringL . loc_filename <$> location)"
]
types = words $
diff --git a/src/Test/Makefile.hs b/src/Test/Makefile.hs
--- a/src/Test/Makefile.hs
+++ b/src/Test/Makefile.hs
@@ -22,3 +22,7 @@
build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]
build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]
build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]
+ writeFile (obj "output.txt") "goodbye"
+ writeFile (obj "Shakefile.hs") "main = writeFile \"output.txt\" \"hello\""
+ build ["@@","--directory=" ++ obj ""]
+ assertContents (obj "output.txt") "hello"
diff --git a/src/Test/Manual.hs b/src/Test/Manual.hs
--- a/src/Test/Manual.hs
+++ b/src/Test/Manual.hs
@@ -21,4 +21,3 @@
() <- cmd [Cwd $ obj "manual", Shell] cmdline
() <- cmd [Cwd $ obj "manual", Shell] [cmdline,"clean"]
assertMissing $ obj "manual/_build/run" <.> exe
- return ()
diff --git a/src/Test/OrderOnly.hs b/src/Test/OrderOnly.hs
--- a/src/Test/OrderOnly.hs
+++ b/src/Test/OrderOnly.hs
@@ -3,6 +3,8 @@
import Development.Shake
import Test.Type
+import System.Directory(removeFile)
+import Control.Exception.Extra
main = shaken test $ \args obj -> do
@@ -23,7 +25,15 @@
orderOnly [src]
liftIO $ appendFile out "x"
+ obj "primary.txt" %> \out -> do
+ need [obj "source.txt"]
+ orderOnly [obj "intermediate.txt"]
+ writeFile' out =<< liftIO (readFile $ obj "intermediate.txt")
+ obj "intermediate.txt" %> \out -> do
+ copyFile' (obj "source.txt") out
+
+
test build obj = do
writeFile (obj "bar.in") "in"
build ["foo.txt","--sleep"]
@@ -39,3 +49,14 @@
writeFile (obj "bar.in") "out"
build ["baz.txt"]
assertContents (obj "baz.txt") "x"
+
+ ignore $ removeFile $ obj "intermediate.txt"
+ writeFile (obj "source.txt") "x"
+ build ["primary.txt","--sleep"]
+ assertContents (obj "intermediate.txt") "x"
+ removeFile $ obj "intermediate.txt"
+ build ["primary.txt","--sleep"]
+ assertMissing $ obj "intermediate.txt"
+ writeFile (obj "source.txt") "y"
+ build ["primary.txt","--sleep"]
+ assertContents (obj "intermediate.txt") "y"
diff --git a/src/Test/Progress.hs b/src/Test/Progress.hs
--- a/src/Test/Progress.hs
+++ b/src/Test/Progress.hs
@@ -2,11 +2,12 @@
module Test.Progress(main) where
-import Prelude(); import General.Prelude
import Development.Shake.Progress
import Test.Type
import System.Directory
import System.FilePath
+import Data.Monoid
+import Prelude
main = shaken test $ \args obj -> return ()
diff --git a/src/Test/Self.hs b/src/Test/Self.hs
--- a/src/Test/Self.hs
+++ b/src/Test/Self.hs
@@ -48,7 +48,7 @@
dep <- readFileLines $ out -<.> "dep"
let xs = map (obj . moduleToFile "deps") dep
need xs
- ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs
+ ds <- fmap (nubOrd . sort . (++) dep . concat) $ mapM readFileLines xs
writeFileLines out ds
obj "//*.dep" %> \out -> do
@@ -63,7 +63,7 @@
need $ hs : map (obj . moduleToFile "hi") deps
ghc $ ["-c",hs,"-isrc","-main-is","Run.main"
,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] ++
- ["-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch
+ ["-DPORTABLE","-fwarn-unused-imports"] -- to test one CPP branch
obj ".pkgs" %> \out -> do
src <- readFile' "shake.cabal"
diff --git a/src/Test/Throttle.hs b/src/Test/Throttle.hs
--- a/src/Test/Throttle.hs
+++ b/src/Test/Throttle.hs
@@ -23,8 +23,8 @@
-- therefore we rerun the test three times, and only fail if it fails on all of them
retry 3 $ do
build ["clean"]
- (s, _) <- duration $ build []
+ (s, _) <- duration $ build ["--no-report"]
-- the 0.1s cap is a guess at an upper bound for how long everything else should take
-- and should be raised on slower machines
assert (s >= 1.4 && s < 1.6) $
- "Bad throttling, expected to take 0.7s + computation time (cap of 0.1s), took " ++ show s ++ "s"
+ "Bad throttling, expected to take 1.4s + computation time (cap of 0.2s), took " ++ show s ++ "s"
diff --git a/src/Test/Util.hs b/src/Test/Util.hs
--- a/src/Test/Util.hs
+++ b/src/Test/Util.hs
@@ -18,3 +18,4 @@
parseMakefile "foo/bar: \\\r\n c:/a1 \\\r\n x\r\n" === [("foo/bar",["c:/a1","x"])]
parseMakefile "output.o: src/file/with\\ space.cpp" === [("output.o",["src/file/with space.cpp"])]
parseMakefile "a: b\\ c" === [("a",["b ","c"])]
+ parseMakefile "a: b\\ c\\ d e" === [("a",["b c d","e"])]
diff --git a/src/Test/Version.hs b/src/Test/Version.hs
new file mode 100644
--- /dev/null
+++ b/src/Test/Version.hs
@@ -0,0 +1,33 @@
+
+module Test.Version(main) where
+
+import Development.Shake
+import Test.Type
+
+
+main = shaken test $ \args obj -> do
+ want [obj "foo.txt"]
+ obj "foo.txt" %> \file -> liftIO $ appendFile file "x"
+
+test build obj = do
+ writeFile (obj "foo.txt") ""
+ v1 <- getHashedShakeVersion [obj "foo.txt"]
+ writeFile (obj "foo.txt") "y"
+ v2 <- getHashedShakeVersion [obj "foo.txt"]
+ assert (v1 /= v2) "Hashes must not be equal"
+
+ build ["clean"]
+ build []
+ assertContents (obj "foo.txt") "x"
+ build ["--rule-version=new","--silent"]
+ assertContents (obj "foo.txt") "xx"
+ build ["--rule-version=new"]
+ assertContents (obj "foo.txt") "xx"
+ build ["--rule-version=extra","--silent"]
+ assertContents (obj "foo.txt") "xxx"
+ build ["--rule-version=more","--no-rule-version"]
+ assertContents (obj "foo.txt") "xxx"
+ build ["--rule-version=more"]
+ assertContents (obj "foo.txt") "xxx"
+ build ["--rule-version=final","--silent"]
+ assertContents (obj "foo.txt") "xxxx"