diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Shake +0.14.3 + Support for the filepath shipped with GHC 7.10 + Add Timeout option to command 0.14.2 #198, add operator to join FilePatterns #198, fix the <.> and other extension methods to work with // diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,6 +27,7 @@ * [Standard Chartered](http://www.standardchartered.com/) have been using Shake since 2009, as described in the section 6 of the [academic paper](http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf). * [factis research GmbH](http://www.factisresearch.com/), as described in their [blog post](http://funktionale-programmierung.de/2014/01/16/build-system-haskell.html). * [Samplecount](http://samplecount.com/) have been using Shake since 2012, as mentioned in their [tweet](https://twitter.com/samplecount/status/491581551730511872). +* [CovenantEyes](http://samplecount.com/) use Shake to build their Windows client, as mentioned in their [tweet](https://twitter.com/eacameron88/status/543219899599163392). * At least 10 other companies are using Shake internally. Is your company using Shake? Write something public (even just a [tweet to `@ndm_haskell`](https://twitter.com/ndm_haskell)) and I'll include a link. diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake -version: 0.14.2 +version: 0.14.3 license: BSD3 license-file: LICENSE category: Development @@ -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.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 +tested-with: GHC==7.10.1, GHC==7.8.3, 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 @@ -42,8 +42,14 @@ src/Test/MakeTutor/hellomake.h src/Test/Tar/list.txt src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja src/Test/Ninja/*.output src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h src/Paths.hs CHANGES.txt README.md @@ -275,6 +281,7 @@ Test.Self Test.Tar Test.Throttle + Test.Tup Test.Unicode Test.Util Test.Verbosity diff --git a/src/Development/Ninja/Lexer.hs b/src/Development/Ninja/Lexer.hs --- a/src/Development/Ninja/Lexer.hs +++ b/src/Development/Ninja/Lexer.hs @@ -10,7 +10,10 @@ import qualified Data.ByteString.Unsafe as BS import Development.Ninja.Type import qualified Data.ByteString.Internal as Internal -import Foreign +import System.IO.Unsafe +import Data.Word +import Foreign.Ptr +import Foreign.Storable import GHC.Exts --------------------------------------------------------------------- @@ -21,7 +24,7 @@ type S = Ptr Word8 chr :: S -> Char -chr x = Internal.w2c $ Internal.inlinePerformIO $ peek x +chr x = Internal.w2c $ unsafePerformIO $ peek x inc :: S -> S inc x = x `plusPtr` 1 @@ -38,7 +41,7 @@ break0 :: (Char -> Bool) -> Str0 -> (Str, Str0) break0 f (Str0 bs) = (BS.unsafeTake i bs, Str0 $ BS.unsafeDrop i bs) where - i = Internal.inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do + i = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do let start = castPtr ptr :: S let end = go start return $! Ptr end `minusPtr` start @@ -52,7 +55,7 @@ break00 :: (Char -> Bool) -> Str0 -> (Str, Str0) break00 f (Str0 bs) = (BS.unsafeTake i bs, Str0 $ BS.unsafeDrop i bs) where - i = Internal.inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do + i = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do let start = castPtr ptr :: S let end = go start return $! Ptr end `minusPtr` start diff --git a/src/Development/Shake.hs b/src/Development/Shake.hs --- a/src/Development/Shake.hs +++ b/src/Development/Shake.hs @@ -141,9 +141,10 @@ system', systemCwd, systemOutput ) where +import Prelude(Maybe, FilePath) -- Since GHC 7.10 duplicates *> + -- I would love to use module export in the above export list, but alas Haddock -- then shows all the things that are hidden in the docs, which is terrible. - import Control.Monad.IO.Class import Development.Shake.Types import Development.Shake.Core hiding (trackAllow) diff --git a/src/Development/Shake/Command.hs b/src/Development/Shake/Command.hs --- a/src/Development/Shake/Command.hs +++ b/src/Development/Shake/Command.hs @@ -31,6 +31,7 @@ import System.Exit import System.IO.Extra import System.Process +import System.Time.Extra import System.Info.Extra import System.IO.Unsafe(unsafeInterleaveIO) @@ -54,6 +55,7 @@ | 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. | 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. | 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. @@ -209,6 +211,14 @@ 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 @@ -237,6 +247,7 @@ -- wait on the process ex <- waitForProcess pid -- END COPIED + stopTimeout when (ResultCode ExitSuccess `notElem` results && ex /= ExitSuccess) $ do failure $ @@ -270,6 +281,7 @@ 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 @@ -280,6 +292,7 @@ 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 diff --git a/src/Development/Shake/FilePath.hs b/src/Development/Shake/FilePath.hs --- a/src/Development/Shake/FilePath.hs +++ b/src/Development/Shake/FilePath.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE CPP #-} -- | A module for 'FilePath' operations exposing "System.FilePath" plus some additional operations. -- -- /Windows note:/ The extension methods ('<.>', 'takeExtension' etc) use the Posix variants since on --- Windows @\"\/\/*\" '<.>' \"txt\"@ produces @\"\/\/*\\\\.txt\"@ +-- Windows @\"\/\/\*\" '<.>' \"txt\"@ produces @\"\/\/\*\\\\.txt\"@ -- (which is bad for 'Development.Shake.FilePattern' values). module Development.Shake.FilePath( module System.FilePath, module System.FilePath.Posix, @@ -17,7 +18,11 @@ import System.FilePath hiding (splitExtension, takeExtension, replaceExtension, dropExtension, addExtension - ,hasExtension, (<.>), splitExtensions, takeExtensions, dropExtensions) + ,hasExtension, (<.>), splitExtensions, takeExtensions, dropExtensions +#if __GLASGOW_HASKELL__ >= 709 + ,(-<.>) +#endif + ) import System.FilePath.Posix (splitExtension, takeExtension, replaceExtension, dropExtension, addExtension ,hasExtension, (<.>), splitExtensions, takeExtensions, dropExtensions) diff --git a/src/Paths.hs b/src/Paths.hs --- a/src/Paths.hs +++ b/src/Paths.hs @@ -6,6 +6,7 @@ import System.IO.Unsafe import System.Directory import Control.Exception +import Text.ParserCombinators.ReadP -- We want getDataFileName to be relative to the current directory even if @@ -19,4 +20,5 @@ return $ curdir ++ "/" ++ x version :: Version -version = Version {versionBranch = [0,0], versionTags = []} +-- can't write a literal Version value since in GHC 7.10 the versionsTag field is deprecated +version = head $ [v | (v,"") <- readP_to_S parseVersion "0.0"] ++ error "version, failed to parse" diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -42,6 +42,7 @@ import qualified Test.Self as Self import qualified Test.Tar as Tar import qualified Test.Throttle as Throttle +import qualified Test.Tup as Tup import qualified Test.Unicode as Unicode import qualified Test.Util as Util import qualified Test.Verbosity as Verbosity @@ -61,7 +62,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] + ,"throttle" * Throttle.main, "verbosity" * Verbosity.main, "tup" * Tup.main] where (*) = (,) diff --git a/src/Test/Command.hs b/src/Test/Command.hs --- a/src/Test/Command.hs +++ b/src/Test/Command.hs @@ -3,6 +3,8 @@ import Development.Shake import Development.Shake.FilePath +import System.Time.Extra +import Control.Monad import Test.Type @@ -33,6 +35,14 @@ Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"] return out + "timeout" !> do + offset <- liftIO offsetTime + Exit exit <- cmd (Timeout 2) "ghc -ignore-dot-ghci -e" ["last [1..]"] + t <- liftIO offset + putNormal $ "Timed out in " ++ showDuration t + 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" @@ -77,3 +87,5 @@ crash ["path_"] ["myexe"] build ["path"] + + build ["timeout"] diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -7,14 +7,12 @@ import Test.Type import Control.Monad import Data.Char -import Data.List +import Data.List.Extra import Data.Maybe import System.Directory import System.Exit -reps from to = map (\x -> if x == from then to else x) - main = shaken noTest $ \args obj -> do let index = "dist/doc/html/shake/index.html" want [obj "Success.txt"] @@ -43,7 +41,7 @@ src <- if "_md" `isSuffixOf` takeBaseName out then fmap (findCodeMarkdown . lines . noR) $ readFile' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md" else - fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ reps '_' '-' (drop 5 $ takeBaseName out) ++ ".html" + fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html" let f i (Stmt x) | whitelist $ head x = [] | otherwise = restmt i $ map undefDots $ trims x f i (Expr x) | takeWhile (not . isSpace) x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x] @@ -71,7 +69,7 @@ ,"import System.Directory(setCurrentDirectory)" ,"import System.Exit" ,"import System.IO"] ++ - ["import " ++ reps '_' '.' (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++ + ["import " ++ replace "_" "." (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++ imports ++ ["(==>) :: Bool -> Bool -> Bool" ,"(==>) = undefined" @@ -105,7 +103,7 @@ filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] filesMd <- getDirectoryFiles "docs" ["*.md"] writeFileChanged out $ unlines $ - ["Part_" ++ reps '-' '_' (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++ + ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++ ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd, takeBaseName x `notElem` ["Developing","Model"]] let needModules = do mods <- readFileLines $ obj "Files.lst"; need [obj m <.> "hs" | m <- mods]; return mods @@ -147,7 +145,6 @@ f [] = [] findCodeMarkdown [] = [] -trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace trims = reverse . dropWhile (all isSpace) . reverse . dropWhile (all isSpace) restmt i ("":xs) = restmt i xs @@ -214,7 +211,8 @@ "_metadata/.database _shake _shake/build ./build.sh build.sh build.bat [out] manual " ++ "docs/manual _build _build/run ninja depfile build.ninja " ++ "Rule CmdResult ShakeValue Monoid Monad Eq Typeable Data " ++ -- work only with constraint kinds - "@ndm_haskell " + "@ndm_haskell " ++ + "*> " = True whitelist x | "foo/" `isPrefixOf` x -- path examples diff --git a/src/Test/Ninja.hs b/src/Test/Ninja.hs --- a/src/Test/Ninja.hs +++ b/src/Test/Ninja.hs @@ -4,7 +4,7 @@ import Development.Shake import Development.Shake.FilePath import qualified Development.Shake.Config as Config -import System.Directory(copyFile) +import System.Directory(copyFile, createDirectoryIfMissing) import Control.Monad import Test.Type import qualified Data.HashMap.Strict as Map @@ -42,6 +42,9 @@ copyFile "src/Test/Ninja/test3-sub.ninja" $ obj "test3-sub.ninja" copyFile "src/Test/Ninja/test3-inc.ninja" $ obj "test3-inc.ninja" copyFile ("src/Test/Ninja/" ++ if null exe then "test3-unix.ninja" else "test3-win.ninja") $ obj "test3-platform.ninja" + createDirectoryIfMissing True $ obj "subdir" + copyFile "src/Test/Ninja/subdir/1.ninja" $ obj "subdir/1.ninja" + copyFile "src/Test/Ninja/subdir/2.ninja" $ obj "subdir/2.ninja" run "-f../../src/Test/Ninja/test3.ninja" assertNonSpace (obj "out3.1") "g4+b1+++i1" assertNonSpace (obj "out3.2") "g4++++i1" diff --git a/src/Test/Ninja/subdir/1.ninja b/src/Test/Ninja/subdir/1.ninja new file mode 100644 --- /dev/null +++ b/src/Test/Ninja/subdir/1.ninja @@ -0,0 +1,2 @@ +# weirdly, Ninja includes are not relative to who includes them +include subdir/2.ninja diff --git a/src/Test/Ninja/subdir/2.ninja b/src/Test/Ninja/subdir/2.ninja new file mode 100644 --- /dev/null +++ b/src/Test/Ninja/subdir/2.ninja diff --git a/src/Test/Ninja/test3.ninja b/src/Test/Ninja/test3.ninja --- a/src/Test/Ninja/test3.ninja +++ b/src/Test/Ninja/test3.ninja @@ -19,3 +19,5 @@ build out3.2: dump v1 = g4 + +include subdir/1.ninja diff --git a/src/Test/Progress.hs b/src/Test/Progress.hs --- a/src/Test/Progress.hs +++ b/src/Test/Progress.hs @@ -2,9 +2,9 @@ module Test.Progress(main) where +import Prelude(); import General.Prelude import Development.Shake.Progress import Test.Type -import Data.Monoid import System.Directory import System.FilePath diff --git a/src/Test/Self.hs b/src/Test/Self.hs --- a/src/Test/Self.hs +++ b/src/Test/Self.hs @@ -44,20 +44,20 @@ need os ghc $ ["-o",out] ++ os - obj "/*.deps" %> \out -> do + obj "//*.deps" %> \out -> do dep <- readFileLines $ out -<.> "dep" let xs = map (obj . moduleToFile "deps") dep need xs ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs writeFileLines out ds - obj "/*.dep" %> \out -> do + obj "//*.dep" %> \out -> do src <- readFile' $ "src" fixPaths (unobj $ out -<.> "hs") let xs = hsImports src xs <- filterM (doesFileExist . ("src" ) . fixPaths . moduleToFile "hs") xs writeFileLines out xs - [obj "/*.o",obj "/*.hi"] &%> \[out,_] -> do + [obj "//*.o",obj "//*.hi"] &%> \[out,_] -> do deps <- readFileLines $ out -<.> "deps" let hs = "src" fixPaths (unobj $ out -<.> "hs") need $ hs : map (obj . moduleToFile "hi") deps diff --git a/src/Test/Tup.hs b/src/Test/Tup.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tup.hs @@ -0,0 +1,41 @@ + +module Test.Tup(main) where + +import Development.Shake +import Development.Shake.Config +import Development.Shake.FilePath +import Development.Shake.Util +import Test.Type +import Data.Maybe + + +main = shaken noTest $ \args obj -> do + -- Example inspired by http://gittup.org/tup/ex_multiple_directories.html + usingConfigFile "src/Test/Tup/root.cfg" + + action $ do + keys <- getConfigKeys + need [x -<.> exe | x <- keys, takeExtension x == ".exe"] + + let objects dir key = do + let f x | takeExtension x == ".c" = obj $ dir x -<.> "o" + | takeExtension x == ".a" = obj $ takeBaseName x "lib" ++ x + | otherwise = error $ "Unknown extension, " ++ x + x <- fmap (fromMaybe $ error $ "Missing config key, " ++ key) $ getConfig key + return $ map f $ words x + + (\x -> x -<.> exe == x) ?> \out -> do + os <- objects "" $ takeBaseName out <.> "exe" + need os + cmd "gcc" os "-o" [out] + + obj "//lib*.a" %> \out -> do + os <- objects (drop 3 $ takeBaseName out) $ drop 3 $ takeFileName out + need os + cmd "ar crs" [out] os + + obj "//*.o" %> \out -> do + let src = "src/Test/Tup" unobj out -<.> "c" + need [src] + () <- cmd "gcc -c -MMD -MF" [out -<.> "d"] [src] "-o" [out] "-O2 -Wall -Isrc/Test/Tup/newmath" + neededMakefileDependencies $ out -<.> "d" diff --git a/src/Test/Tup/hello.c b/src/Test/Tup/hello.c new file mode 100644 --- /dev/null +++ b/src/Test/Tup/hello.c @@ -0,0 +1,9 @@ +#include +#include "square.h" + +int main(void) +{ + printf("Hi, everybody!\n"); + printf("Five squared is: %i\n", square(5)); + return 0; +} diff --git a/src/Test/Tup/newmath/root.cfg b/src/Test/Tup/newmath/root.cfg new file mode 100644 --- /dev/null +++ b/src/Test/Tup/newmath/root.cfg @@ -0,0 +1,2 @@ + +newmath.a = square.c diff --git a/src/Test/Tup/newmath/square.c b/src/Test/Tup/newmath/square.c new file mode 100644 --- /dev/null +++ b/src/Test/Tup/newmath/square.c @@ -0,0 +1,6 @@ +#include "square.h" + +int square(int x) +{ + return x * x; +} diff --git a/src/Test/Tup/newmath/square.h b/src/Test/Tup/newmath/square.h new file mode 100644 --- /dev/null +++ b/src/Test/Tup/newmath/square.h @@ -0,0 +1,1 @@ +int square(int x); diff --git a/src/Test/Tup/root.cfg b/src/Test/Tup/root.cfg new file mode 100644 --- /dev/null +++ b/src/Test/Tup/root.cfg @@ -0,0 +1,4 @@ + +hello.exe = hello.c newmath.a + +include src/Test/Tup/newmath/root.cfg diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -32,12 +32,12 @@ putStrLn $ "## BUILD " ++ unwords (name:args) args <- return $ delete "--sleep" args let out = "output/" ++ name ++ "/" + let obj x = if "/" `isPrefixOf` x then init out ++ x else out ++ x createDirectoryIfMissing True out case args of "test":extra -> do putStrLn $ "## TESTING " ++ name -- if the extra arguments are not --quiet/--loud it's probably going to go wrong - let obj x = if "/" `isPrefixOf` x then init out ++ x else out ++ x test (\args -> withArgs (name:args ++ extra) $ shaken test rules sleeper) obj putStrLn $ "## FINISHED TESTING " ++ name "clean":_ -> removeDirectoryRecursive out @@ -66,7 +66,7 @@ shakeWithClean (removeDirectoryRecursive out) (shakeOptions{shakeFiles=out, shakeReport=["output/" ++ name ++ "/report.html"], shakeLint=Just $ if isJust tracker then LintTracker else LintBasic}) - (rules files (out++)) + (rules files obj) shakeWithClean :: IO () -> ShakeOptions -> Rules () -> IO ()