shake 0.19.7 → 0.19.8
raw patch · 28 files changed
+83/−51 lines, 28 files
Files
- CHANGES.txt +5/−0
- LICENSE +1/−1
- README.md +1/−1
- shake.cabal +15/−6
- src/Development/Ninja/All.hs +2/−2
- src/Development/Ninja/Parse.hs +2/−1
- src/Development/Shake.hs +1/−1
- src/Development/Shake/Command.hs +1/−1
- src/Development/Shake/FilePath.hs +3/−2
- src/Development/Shake/Internal/Args.hs +2/−2
- src/Development/Shake/Internal/Core/Action.hs +1/−1
- src/Development/Shake/Internal/Core/Build.hs +2/−2
- src/Development/Shake/Internal/Core/Rules.hs +1/−1
- src/Development/Shake/Internal/Core/Storage.hs +2/−2
- src/Development/Shake/Internal/Demo.hs +1/−1
- src/Development/Shake/Internal/Rules/Directory.hs +1/−1
- src/Development/Shake/Internal/Rules/Files.hs +1/−1
- src/Development/Shake/Internal/Rules/Oracle.hs +1/−1
- src/General/Binary.hs +8/−7
- src/General/Extra.hs +8/−0
- src/Test/Existence.hs +7/−6
- src/Test/FilePath.hs +2/−1
- src/Test/History.hs +1/−0
- src/Test/Oracle.hs +4/−2
- src/Test/Progress.hs +4/−3
- src/Test/Random.hs +1/−1
- src/Test/Self.hs +2/−2
- src/Test/SelfMake.hs +3/−2
CHANGES.txt view
@@ -1,5 +1,10 @@ Changelog for Shake (* = breaking change) +0.9.8, released 2024, 2024-01-14+ Test with GHC 9.8+ #844, optimise database reading/writing with use unsafeUseAsCString+ #836, add threaded flag to disable using threaded runtime+ #837, require filepath-1.14 0.9.7, released 2022-09-15 #815, improve corrupt database handling code Don't say (changed) for files that don't build
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2011-2022.+Copyright Neil Mitchell 2011-2024. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,4 +1,4 @@-# Shake [](https://hackage.haskell.org/package/shake) [](https://www.stackage.org/package/shake) [](https://github.com/ndmitchell/shake/actions)+# Shake [](https://hackage.haskell.org/package/shake) [](https://www.stackage.org/package/shake) [](https://github.com/ndmitchell/shake/actions) Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com).
shake.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.18 build-type: Simple name: shake-version: 0.19.7+version: 0.19.8 license: BSD3 license-file: LICENSE category: Development, Shake author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2011-2022+copyright: Neil Mitchell 2011-2024 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a@@ -30,7 +30,7 @@ (e.g. compiler version). homepage: https://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues-tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6+tested-with: GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8 extra-doc-files: CHANGES.txt README.md@@ -81,6 +81,11 @@ manual: True description: Embed data files into the shake library +flag threaded+ default: True+ manual: True+ description: Build shake with the threaded RTS+ library default-language: Haskell2010 hs-source-dirs: src@@ -91,7 +96,7 @@ deepseq >= 1.1, directory >= 1.2.7.0, extra >= 1.6.19,- filepath,+ filepath >= 1.4, filepattern, hashable >= 1.1.2.3, heaps >= 0.3.6.1,@@ -205,7 +210,9 @@ executable shake default-language: Haskell2010 hs-source-dirs: src- ghc-options: -main-is Run.main -rtsopts -threaded "-with-rtsopts=-I0 -qg"+ ghc-options: -main-is Run.main -rtsopts+ if flag(threaded)+ ghc-options: -threaded "-with-rtsopts=-I0 -qg" main-is: Run.hs build-depends: base == 4.*,@@ -328,7 +335,9 @@ type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: src- ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K -threaded+ ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K+ if flag(threaded)+ ghc-options: -threaded build-depends: base == 4.*,
src/Development/Ninja/All.hs view
@@ -22,7 +22,7 @@ import System.Info.Extra -- Internal imports-import General.Extra(removeFile_)+import General.Extra(removeFile_, headErr) import General.Timing(addTiming) import General.Makefile(parseMakefile) import Development.Shake.Internal.FileName(filepathNormalise, fileNameFromString)@@ -83,7 +83,7 @@ else Map.keys singles ++ Map.keys multiples (\x -> map BS.unpack . fst <$> Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in- build needDeps phonys rules pools out2 $ snd $ multiples Map.! head out2+ build needDeps phonys rules pools out2 $ snd $ multiples Map.! headErr out2 (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in build needDeps phonys rules pools [out2] $ singles Map.! out2
src/Development/Ninja/Parse.hs view
@@ -7,6 +7,7 @@ import Development.Ninja.Type import Development.Ninja.Lexer import Control.Monad+import General.Extra parse :: FilePath -> Env Str Str -> IO Ninja@@ -37,7 +38,7 @@ let build = Build rule env normal implicit orderOnly binds pure $ if rule == BS.pack "phony" then ninja{phonys = [(x, normal ++ implicit ++ orderOnly) | x <- outputs] ++ phonys}- else if length outputs == 1 then ninja{singles = (head outputs, build) : singles}+ else if length outputs == 1 then ninja{singles = (headErr outputs, build) : singles} else ninja{multiples = (outputs, build) : multiples} LexRule name -> pure ninja{rules = (name, Rule binds) : rules}
src/Development/Shake.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, ConstraintKinds, PatternSynonyms #-}+{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds, PatternSynonyms #-} -- | This module is used for defining Shake build systems. As a simple example of a Shake build system, -- let us build the file @result.tar@ from the files listed by @result.txt@:
src/Development/Shake/Command.hs view
@@ -295,7 +295,7 @@ let cwd = listToMaybe $ reverse [x | Cwd x <- opts] putVerbose $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++- last (showCommandForUser2 prog args : [x | UserCommand x <- opts])+ lastDef (showCommandForUser2 prog args) [x | UserCommand x <- opts] verb <- getVerbosity -- run quietly to suppress the tracer (don't want to print twice) (if verb >= Verbose then quietly else id) act
src/Development/Shake/FilePath.hs view
@@ -15,6 +15,7 @@ import System.Directory (canonicalizePath) import System.Info.Extra import Data.List.Extra+import Data.Maybe import qualified System.FilePath as Native import System.FilePath hiding@@ -128,8 +129,8 @@ (True,False) -> "/." (False,True) -> "./" (False,False) -> "."- | otherwise = (if pre then id else tail) $ (if pos then id else init) x- where pre = sep $ head $ o ++ " "+ | otherwise = (if pre then id else drop1) $ (if pos then id else init) x+ where pre = sep $ fromMaybe ' ' $ listToMaybe o pos = sep $ last $ " " ++ o g i [] = replicate i ".."
src/Development/Shake/Internal/Args.hs view
@@ -401,8 +401,8 @@ _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument" progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of- Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)- Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)+ Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tailErr file], id)+ Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tailErr file], id) _ -> ([],) <$> func x progress _ = throwImpure $ errorInternal "incomplete pattern, progress"
src/Development/Shake/Internal/Core/Action.hs view
@@ -583,7 +583,7 @@ res <- Action $ tryRAW $ do -- make sure we are using one of the local's that we are computing -- we things like stack, blockApply etc. work as expected- modifyRW $ const $ localClearMutable $ snd3 $ head now+ modifyRW $ const $ localClearMutable $ snd3 $ headErr now start <- liftIO offsetTime fromAction $ many $ map fst3 now end <- liftIO start
src/Development/Shake/Internal/Core/Build.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables, NamedFieldPuns, GADTs #-}-{-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-}+{-# LANGUAGE Rank2Types, ConstraintKinds, TypeOperators, TupleSections, ViewPatterns #-} module Development.Shake.Internal.Core.Build( getDatabaseValue, getDatabaseValueGeneric,@@ -244,7 +244,7 @@ -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible, -- use 'apply' to allow parallelism. apply1 :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value-apply1 = withFrozenCallStack $ fmap head . apply . pure+apply1 = withFrozenCallStack $ fmap headErr . apply . pure
src/Development/Shake/Internal/Core/Rules.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, NamedFieldPuns #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-}-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies, TypeOperators, DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} module Development.Shake.Internal.Core.Rules(
src/Development/Shake/Internal/Core/Storage.hs view
@@ -49,8 +49,8 @@ -- * 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-14-" ++ os ++ "-" ++ arch ++ "-" ++ 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+ where s = tailErr $ init $ show x -- call show, then take off the leading/trailing quotes+ -- ensures we do not get \r or \n in the user portion messageCorrupt :: FilePath -> SomeException -> IO [String]
src/Development/Shake/Internal/Demo.hs view
@@ -41,7 +41,7 @@ dir <- if empty then getCurrentDirectory else do home <- getHomeDirectory dir <- getDirectoryContents home- pure $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)+ pure $ home </> headErr (map ("shake-demo" ++) ("":map show [2..]) \\ dir) putStrLn "% The Shake demo uses an empty directory, OK to use:" putStrLn $ "% " ++ dir
src/Development/Shake/Internal/Rules/Directory.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds #-} -- | Both System.Directory and System.Environment wrappers module Development.Shake.Internal.Rules.Directory(
src/Development/Shake/Internal/Rules/Files.hs view
@@ -165,7 +165,7 @@ ps &%> act | not $ compatible ps = error $ unlines $ "All patterns to &%> must have the same number and position of ** and * wildcards" :- ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]+ ["* " ++ p ++ (if compatible [p, headErr ps] then "" else " (incompatible)") | p <- ps] | otherwise = withFrozenCallStack $ do forM_ (zipFrom 0 ps) $ \(i,p) -> (if simple p then id else priority 0.5) $
src/Development/Shake/Internal/Rules/Oracle.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds #-} module Development.Shake.Internal.Rules.Oracle( addOracle, addOracleCache, addOracleHash,
src/General/Binary.hs view
@@ -14,6 +14,7 @@ import Data.Binary import Data.List.Extra import Data.Tuple.Extra+import Foreign.Marshal.Utils import Foreign.Storable import Foreign.Ptr import System.IO.Unsafe as U@@ -91,7 +92,7 @@ getEx :: BS.ByteString -> a instance BinaryEx BS.ByteString where- putEx x = Builder n $ \ptr i -> BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+ putEx x = Builder n $ \ptr i -> BS.unsafeUseAsCString x $ \bs -> copyBytes (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) where n = BS.length x getEx = id @@ -100,7 +101,7 @@ let go _ [] = pure () go i (x:xs) = do let n = BS.length x- BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+ BS.unsafeUseAsCString x $ \bs -> copyBytes (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) go (i+n) xs go i $ LBS.toChunks x getEx = LBS.fromChunks . pure@@ -114,12 +115,12 @@ pokeByteOff p i (fromIntegral n :: Word32) for2M_ [4+i,8+i..] ns $ \i x -> pokeByteOff p i (fromIntegral x :: Word32) p<- pure $ p `plusPtr` (i + 4 + (n * 4))- for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.useAsCStringLen x $ \(bs, n) ->- BS.memcpy (p `plusPtr` i) (castPtr bs) (fromIntegral n)+ for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.unsafeUseAsCStringLen x $ \(bs, n) ->+ copyBytes (p `plusPtr` i) (castPtr bs) (fromIntegral n) where ns = map BS.length xs n = length ns - getEx bs = unsafePerformIO $ BS.useAsCString bs $ \p -> do+ getEx bs = unsafePerformIO $ BS.unsafeUseAsCString bs $ \p -> do n <- fromIntegral <$> (peekByteOff p 0 :: IO Word32) ns :: [Word32] <- forM [1..fromIntegral n] $ \i -> peekByteOff p (i * 4) pure $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns@@ -175,7 +176,7 @@ putExStorable x = Builder (sizeOf x) $ \p i -> pokeByteOff p i x getExStorable :: forall a . Storable a => BS.ByteString -> a-getExStorable = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+getExStorable = \bs -> unsafePerformIO $ BS.unsafeUseAsCStringLen bs $ \(p, size) -> if size /= n then error "size mismatch" else peek (castPtr p) where n = sizeOf (undefined :: a) @@ -186,7 +187,7 @@ where n = sizeOf (undefined :: a) getExStorableList :: forall a . Storable a => BS.ByteString -> [a]-getExStorableList = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+getExStorableList = \bs -> unsafePerformIO $ BS.unsafeUseAsCStringLen bs $ \(p, size) -> let (d,m) = size `divMod` n in if m /= 0 then error "size mismatch" else forM [0..d-1] $ \i -> peekElemOff (castPtr p) i where n = sizeOf (undefined :: a)
src/General/Extra.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, ConstraintKinds, GeneralizedNewtypeDeriving, ViewPatterns #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-} module General.Extra( getProcessorCount,@@ -10,6 +11,7 @@ maximum', maximumBy', unconcat, fastAt,+ headErr, tailErr, zipExact, zipWithExact, isAsyncException, showDurationSecs,@@ -69,6 +71,12 @@ unconcat [] _ = [] unconcat (a:as) bs = b1 : unconcat as b2 where (b1,b2) = splitAt (length a) bs++headErr :: [a] -> a+headErr = head++tailErr :: [a] -> [a]+tailErr = tail ---------------------------------------------------------------------
src/Test/Existence.hs view
@@ -1,16 +1,17 @@ module Test.Existence(main) where -import Development.Shake (getDirectoryFilesIO)-import Development.Shake.Internal.FileInfo (getFileInfo)-import Development.Shake.Internal.FileName (fileNameFromString)-import System.Directory (getCurrentDirectory)-import System.FilePath ((</>))+import Development.Shake+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.FileName+import System.Directory+import System.FilePath+import General.Extra main :: IO () -> IO () main _ = do cwd <- getCurrentDirectory someFiles <- getDirectoryFilesIO cwd ["*"]- let someFile = head someFiles+ let someFile = headErr someFiles assertIsJust $ getFileInfo False $ fileNameFromString someFile let fileThatCantExist = someFile </> "fileThatCantExist"
src/Test/FilePath.hs view
@@ -13,6 +13,7 @@ import System.Info.Extra import System.Directory import qualified System.IO.Extra as IO+import General.Extra newtype File = File String deriving Show@@ -68,7 +69,7 @@ sep = Native.isPathSeparator noDrive = if isWindows then drop1 else id ps = [y /= ""- ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y))+ ,null x || (sep (headErr x) == sep (headErr y) && sep (last x) == sep (last y)) ,not $ "/./" `isInfixOf` y ,not isWindows || '\\' `notElem` y ,not $ "//" `isInfixOf` noDrive y
src/Test/History.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Test.History(main) where
src/Test/Oracle.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds, ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, TypeOperators, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Test.Oracle(main) where @@ -12,6 +13,7 @@ import Test.Type hiding (RandomType) import qualified Test.Type as T import Control.Monad+import General.Extra -- These are instances we'll compute over@@ -32,7 +34,7 @@ type instance RuleResult T.RandomType = Int data Define = Define String String -- this type produces this result-opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tail . breakOn "=") "type=value") ""]+opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tailErr . breakOn "=") "type=value") ""] main = testBuildArgs test opt $ \args -> do addOracle $ \(T.RandomType _) -> pure 42
src/Test/Progress.hs view
@@ -5,6 +5,7 @@ import Test.Type import System.Directory.Extra import System.FilePath+import General.Extra main = testBuild test $ pure ()@@ -17,8 +18,8 @@ progEx :: Double -> [Double] -> IO [Double] progEx mxDone todo = do let resolution = 10000 -- Use resolution to get extra detail on the numbers- let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)- let res = progressReplay $ zip (map (*resolution) [1..]) $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done+ let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tailErr todo)+ let res = progressReplay $ zip (map (*resolution) [1..]) $ tailErr $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done pure $ (0/0) : map ((/ resolution) . actualSecs) res @@ -40,7 +41,7 @@ -- the first value must be plausible, or missing xs <- prog [187]- assertBool (isNaN $ head xs) "No first value"+ assertBool (isNaN $ headErr xs) "No first value" -- desirable properties, could be weakened xs <- progEx 2 $ 100:map (*2) [10,9..1]
src/Test/Random.hs view
@@ -106,7 +106,7 @@ build $ ("-j" ++ show j) : map ((++) "--arg=" . show) (xs ++ map Want wants) let value i =- let ys = head [ys | Logic j ys <- xs, j == i]+ let ys = headErr [ys | Logic j ys <- xs, j == i] in Multiple $ flip map ys $ map $ \case Input i -> Single $ if i `elem` negated then negate i else i Output i -> value i
src/Test/Self.hs view
@@ -19,8 +19,8 @@ type instance RuleResult GhcPkg = [String] type instance RuleResult GhcFlags = [String] --- Doesn't work on the Windows CI for reasons I don't understand-main = testBuild (notWindowsCI . defaultTest) $ do+-- Doesn't work on CI, seems self-building under `cabal test` is just hard+main = testBuild (notCI . defaultTest) $ do let moduleToFile ext xs = replace "." "/" xs <.> ext want ["Main" <.> exe]
src/Test/SelfMake.hs view
@@ -18,7 +18,8 @@ type instance RuleResult GhcPkg = [String] type instance RuleResult GhcFlags = [String] -main = testBuild (notWindowsCI . defaultTest) $ do+-- Doesn't work on CI, seems self-building under `cabal test` is just hard+main = testBuild (notCI . defaultTest) $ do want ["Main" <.> exe] ghcPkg <- addOracleHash $ \GhcPkg{} -> do@@ -45,7 +46,7 @@ trackAllow ["**/*.o","**/*.hi","Makefile"] ghc $ ["-M",run] ++ flags- need . filter (\x -> takeExtension x == ".hs") . concatMap snd . parseMakefile =<< liftIO (readFile "Makefile")+ need . concatMap (filter (\x -> takeExtension x == ".hs") . snd) . parseMakefile =<< liftIO (readFile "Makefile") ghc $ ["-o",out,run,"-j4"] ++ flags ".pkgs" %> \out -> do