shake 0.14.3 → 0.15
raw patch · 47 files changed
+872/−437 lines, 47 filesdep ~basedep ~extradep ~process
Dependency ranges changed: base, extra, process
Files
- CHANGES.txt +20/−0
- LICENSE +1/−1
- docs/Manual.md +3/−3
- docs/manual/Build.hs +1/−1
- shake.cabal +7/−6
- src/Development/Ninja/All.hs +1/−1
- src/Development/Shake.hs +7/−7
- src/Development/Shake/Args.hs +2/−1
- src/Development/Shake/ByteString.hs +1/−1
- src/Development/Shake/Command.hs +178/−184
- src/Development/Shake/Config.hs +1/−0
- src/Development/Shake/Core.hs +94/−13
- src/Development/Shake/Database.hs +5/−4
- src/Development/Shake/Derived.hs +24/−1
- src/Development/Shake/Errors.hs +11/−10
- src/Development/Shake/FileInfo.hs +9/−11
- src/Development/Shake/FilePattern.hs +1/−2
- src/Development/Shake/Monad.hs +2/−2
- src/Development/Shake/Progress.hs +2/−2
- src/Development/Shake/Resource.hs +2/−2
- src/Development/Shake/Rules/Directory.hs +1/−0
- src/Development/Shake/Rules/File.hs +12/−7
- src/Development/Shake/Rules/Files.hs +3/−2
- src/Development/Shake/Rules/Oracle.hs +1/−1
- src/Development/Shake/Rules/OrderOnly.hs +3/−27
- src/Development/Shake/Shake.hs +0/−2
- src/Development/Shake/Storage.hs +21/−14
- src/Development/Shake/Types.hs +14/−12
- src/General/Bilist.hs +2/−2
- src/General/Concurrent.hs +1/−0
- src/General/Extra.hs +17/−14
- src/General/Prelude.hs +0/−11
- src/General/Process.hs +197/−0
- src/Run.hs +35/−16
- src/Test.hs +2/−1
- src/Test/Basic.hs +4/−1
- src/Test/Command.hs +94/−58
- src/Test/Digest.hs +11/−1
- src/Test/Docs.hs +17/−10
- src/Test/Makefile.hs +4/−0
- src/Test/Manual.hs +0/−1
- src/Test/OrderOnly.hs +21/−0
- src/Test/Progress.hs +2/−1
- src/Test/Self.hs +2/−2
- src/Test/Throttle.hs +2/−2
- src/Test/Util.hs +1/−0
- src/Test/Version.hs +33/−0
CHANGES.txt view
@@ -1,5 +1,25 @@ Changelog for Shake +0.15+ #203, make shakeFiles a directory rather than a file prefix+ #220, add getHashedShakeVersion helper+ #220, add shakeVersionIgnore to ignore version numbers+ #219, run Shakefile.hs from the shake binary+ #218, fix issues with incorrect unchanging with no digests+ #218, fix issue with ChangeModtimeAndDigest on unchanging files+ #216, work around GHC 7.10 RC3 bug 10176+ #213, add phonys, a predicate phony rule+ Add CmdTime and CmdLine results to cmd/command+ Fix parseMakefile for words with multiple escapes in them+ #205, add WithStdout, like WithStderr+ #27, add support for capturing Stdout/Stderr with bytestrings+ Add FileStdout/FileStderr to write a stream direct to a file+ #211, add Stdouterr to capture both Stdout and Stderr streams+ Require extra-1.1 (to use nubOrd)+ Generalise cmd to work with Maybe [String]+ Add unit for use with cmd+ IMPORTANT: Incompatible on disk format change+ #209, improve orderOnly dependencies 0.14.3 Support for the filepath shipped with GHC 7.10 Add Timeout option to command
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2011-2014.+Copyright Neil Mitchell 2011-2015. All rights reserved. Redistribution and use in source and binary forms, with or without
docs/Manual.md view
@@ -10,7 +10,7 @@ import Development.Shake.Util main :: IO ()- main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do+ main = shakeArgs shakeOptions{shakeFiles="_build"} $ do want ["_build/run" <.> exe] phony "clean" $ do@@ -55,7 +55,7 @@ import Development.Shake.Util   main :: IO ()-main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do+main = shakeArgs shakeOptions{shakeFiles="_build"} $ do <i>build rules</i> </pre> @@ -303,7 +303,7 @@ * `build --help` will list out all flags supported by the build system, currently 36 flags. Most flags supported by `make` are also supported by Shake based build systems. * `build -j8` will compile up to 8 rules simultaneously, by default Shake uses 1 processor. -Most flags can also be set within the program by modifying the `shakeOptions` value. As an example, `build --metadata=_metadata/` causes all Shake metadata files to be stored with names such as `_metadata/.database`. Alternatively we can write `shakeOptions{shakeFiles="_metadata/"}` instead of our existing `shakeFiles="_build/"`. Values passed on the command line take preference over those given by `shakeOptions`. Multiple overrides can be given to `shakeOptions` by separating them with a comma, for example `shakeOptions{shakeFiles="_build/",shakeThreads=8}`.+Most flags can also be set within the program by modifying the `shakeOptions` value. As an example, `build --metadata=_metadata` causes all Shake metadata files to be stored with names such as `_metadata/.shake.database`. Alternatively we can write `shakeOptions{shakeFiles="_metadata"}` instead of our existing `shakeFiles="_build"`. Values passed on the command line take preference over those given by `shakeOptions`. Multiple overrides can be given to `shakeOptions` by separating them with a comma, for example `shakeOptions{shakeFiles="_build",shakeThreads=8}`. <span class="target" id="progress"></span>
docs/manual/Build.hs view
@@ -4,7 +4,7 @@ import Development.Shake.Util main :: IO ()-main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do+main = shakeArgs shakeOptions{shakeFiles="_build"} $ do want ["_build/run" <.> exe] phony "clean" $ do
shake.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.14.3+version: 0.15 license: BSD3 license-file: LICENSE-category: Development+category: Development, Shake author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2011-2014+copyright: Neil Mitchell 2011-2015 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a@@ -31,7 +31,7 @@ (e.g. compiler version). homepage: http://www.shakebuild.com/ bug-reports: https://github.com/ndmitchell/shake/issues-tested-with: GHC==7.10.1, GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2+tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 extra-source-files: src/Test/C/constants.c src/Test/C/constants.h@@ -100,7 +100,7 @@ js-jquery, js-flot, transformers >= 0.2,- extra >= 0.7,+ extra >= 1.1, deepseq >= 1.1 if flag(portable)@@ -154,7 +154,7 @@ General.Concurrent General.Extra General.Intern- General.Prelude+ General.Process General.String General.Template General.Timing@@ -285,3 +285,4 @@ Test.Unicode Test.Util Test.Verbosity+ Test.Version
src/Development/Ninja/All.hs view
@@ -145,7 +145,7 @@ let bad = xs `difference` allDependencies build case bad of [] -> return ()- x:_ -> errorStructured+ x:_ -> liftIO $ errorStructured "Lint checking error - file in deps is generated and not a pre-dependency" [("File", Just $ BS.unpack x)] ""
src/Development/Shake.hs view
@@ -78,11 +78,11 @@ -- commands the program appears \"idle\" very often, triggering regular unnecessary garbage collection, stealing -- resources from the program doing actual work. ----- * Omit @-threaded@: In GHC 7.6 and earlier bug 7646 <http://ghc.haskell.org/trac/ghc/ticket/7646>+-- * With GHC 7.6 and before, omit @-threaded@: A GHC bug 7646 <http://ghc.haskell.org/trac/ghc/ticket/7646> -- 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, (?==), (<//>),
src/Development/Shake/Args.hs view
@@ -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."
src/Development/Shake/ByteString.hs view
@@ -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 [] = []
src/Development/Shake/Command.hs view
@@ -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
src/Development/Shake/Config.hs view
@@ -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.
src/Development/Shake/Core.hs view
@@ -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
src/Development/Shake/Database.hs view
@@ -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,..}
src/Development/Shake/Derived.hs view
@@ -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 ()
src/Development/Shake/Errors.hs view
@@ -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)
src/Development/Shake/FileInfo.hs view
@@ -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
src/Development/Shake/FilePattern.hs view
@@ -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
src/Development/Shake/Monad.hs view
@@ -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
src/Development/Shake/Progress.hs view
@@ -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
src/Development/Shake/Resource.hs view
@@ -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 #-}
src/Development/Shake/Rules/Directory.hs view
@@ -23,6 +23,7 @@ import Development.Shake.FilePath import Development.Shake.FilePattern import General.Extra+import Prelude newtype DoesFileExistQ = DoesFileExistQ FilePath
src/Development/Shake/Rules/File.hs view
@@ -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
src/Development/Shake/Rules/Files.hs view
@@ -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
src/Development/Shake/Rules/Oracle.hs view
@@ -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 ... -- @ --
src/Development/Shake/Rules/OrderOnly.hs view
@@ -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
src/Development/Shake/Shake.hs view
@@ -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 ()
src/Development/Shake/Storage.hs view
@@ -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
src/Development/Shake/Types.hs view
@@ -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
src/General/Bilist.hs view
@@ -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]
src/General/Concurrent.hs view
@@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad import Data.IORef+import Prelude ---------------------------------------------------------------------
src/General/Extra.hs view
@@ -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
− src/General/Prelude.hs
@@ -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
+ src/General/Process.hs view
@@ -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
src/Run.hs view
@@ -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
src/Test.hs view
@@ -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 (*) = (,)
src/Test/Basic.hs view
@@ -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"
src/Test/Command.hs view
@@ -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
src/Test/Digest.hs view
@@ -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'
src/Test/Docs.hs view
@@ -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 "<pre>" x = f (Stmt . shift . lines . strip) "</pre>" 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 @@ ,"<i>actions</i>" ,"() <- 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 $
src/Test/Makefile.hs view
@@ -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"
src/Test/Manual.hs view
@@ -21,4 +21,3 @@ () <- cmd [Cwd $ obj "manual", Shell] cmdline () <- cmd [Cwd $ obj "manual", Shell] [cmdline,"clean"] assertMissing $ obj "manual/_build/run" <.> exe- return ()
src/Test/OrderOnly.hs view
@@ -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"
src/Test/Progress.hs view
@@ -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 ()
src/Test/Self.hs view
@@ -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"
src/Test/Throttle.hs view
@@ -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"
src/Test/Util.hs view
@@ -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"])]
+ src/Test/Version.hs view
@@ -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"