shake 0.19 → 0.19.1

raw patch · 18 files changed

+49/−32 lines, 18 files

Files

• CHANGES.txt +5/−0
• shake.cabal +2/−2
• src/Development/Ninja/All.hs +1/−1
• src/Development/Ninja/Lexer.hs +4/−4
• src/Development/Ninja/Parse.hs +2/−2
• src/Development/Shake/Command.hs +5/−2
• src/Development/Shake/Internal/Core/Rules.hs +6/−1
• src/Development/Shake/Internal/Core/Run.hs +1/−1
• src/Development/Shake/Internal/Core/Storage.hs +1/−1
• src/Development/Shake/Internal/Core/Types.hs +7/−7
• src/Development/Shake/Internal/Demo.hs +1/−1
• src/Development/Shake/Internal/History/Shared.hs +6/−3
• src/Development/Shake/Internal/Options.hs +2/−1
• src/Development/Shake/Internal/Profile.hs +1/−1
• src/Development/Shake/Internal/Value.hs +2/−2
• src/General/Extra.hs +1/−1
• src/General/Ids.hs +1/−1
• src/Test/Pool.hs +1/−1

@@ -1,5 +1,10 @@ Changelog for Shake (* = breaking change) +0.19.1, released 2020-06-06+    #757, make sure shared cache writes are atomic+    Remove a small space leak if using the Database module+    #755, add instance IsCmdArgument (NonEmpty String)+    #754, tighten bounds to exclude GHC 7.10 0.19, released 2020-05-23     #738, improve the help text     #679, allow Ninja to depend on a directory

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.19+version:            0.19.1 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -85,7 +85,7 @@     default-language: Haskell2010     hs-source-dirs:   src     build-depends:-        base >= 4.8,+        base >= 4.9,         binary,         bytestring,         deepseq >= 1.1,

@@ -93,7 +93,7 @@ resolvePhony mp = f $ Left 100     where         f (Left 0) x = f (Right []) x-        f (Right xs) x | x `elem` xs = error $ "Recursive phony involving " ++ BS.unpack x+        f (Right xs) x | x `elem` xs = error $ "Ninja recursive phony involving " ++ BS.unpack x         f a x = case Map.lookup x mp of             Nothing -> [x]             Just xs -> concatMap (f $ either (Left . subtract 1) (Right . (x:)) a) xs

@@ -164,7 +164,7 @@     , ('=',x) <- list0 $ jumpCont $ dropSpace x     , (exp,x) <- lexxExpr False False $ jumpCont $ dropSpace x     = ctor var exp : lexerLoop x-lexxBind _ x = error $ show ("parse failed when parsing binding", take0 100 x)+lexxBind _ x = error $ "Ninja parse failed when parsing binding, " ++ show (take0 100 x)  lexxFile :: (Expr -> Lexeme) -> Str0 -> [Lexeme] lexxFile ctor x@@ -182,11 +182,11 @@     (a,c_x) | c <- head0 c_x, x <- tail0 c_x -> case c of         ' ' -> add a $ lexxExprs stopColon $ dropSpace x         ':' | stopColon -> new a x-        _ | stopColon -> error "expected a colon"+        _ | stopColon -> error "Ninja parsing, expected a colon"         '\r' -> new a $ dropN x         '\n' -> new a x         '\0' -> new a c_x-        _ -> error "unexpected expression in Ninja"+        _ -> error "Ninja parsing, unexpected expression"     where         new a x = add a ([], x)         add (Exprs []) x = x@@ -218,7 +218,7 @@             '\r' -> f $ dropSpace $ dropN x             '{' | (name,x) <- span0 isVarDot x, not $ BS.null name, ('}',x) <- list0 x -> Var name $: f x             _ | (name,x) <- span0 isVar c_x, not $ BS.null name -> Var name $: f x-            _ -> error "Unexpect $ followed by unexpected stuff"+            _ -> error "Ninja parsing, unexpect $ followed by unexpected stuff"  jumpCont :: Str0 -> Str0 jumpCont o

@@ -58,7 +58,7 @@         addBind env a b         pure ninja     LexBind a _ ->-        error $ "Unexpected binding defining " ++ BS.unpack a+        error $ "Ninja parsing, unexpected binding defining " ++ BS.unpack a   splitDeps :: [Str] -> ([Str], [Str], [Str])@@ -76,4 +76,4 @@         x <- askExpr env x         case BS.readInt x of             Just (i, n) | BS.null n -> pure i-            _ -> error $ "Could not parse depth field in pool, got: " ++ BS.unpack x+            _ -> error $ "Ninja parsing, could not parse depth field in pool, got: " ++ BS.unpack x

@@ -26,7 +26,9 @@ import Control.Exception.Extra import Data.Char import Data.Either.Extra+import Data.Foldable (toList) import Data.List.Extra+import Data.List.NonEmpty (NonEmpty) import Data.Maybe import Data.Data import Data.Semigroup@@ -38,7 +40,7 @@ import System.Process import System.Info.Extra import System.Time.Extra-import System.IO.Unsafe(unsafeInterleaveIO)+import System.IO.Unsafe (unsafeInterleaveIO) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.UTF8 as UTF8@@ -740,6 +742,7 @@ instance IsCmdArgument () where toCmdArgument = mempty instance IsCmdArgument String where toCmdArgument = CmdArgument . map Right . words instance IsCmdArgument [String] where toCmdArgument = CmdArgument . map Right+instance IsCmdArgument (NonEmpty String) where toCmdArgument = toCmdArgument . toList instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . pure . Left instance IsCmdArgument [CmdOption] where toCmdArgument = CmdArgument . map Left instance IsCmdArgument CmdArgument where toCmdArgument = id@@ -754,4 +757,4 @@ showCommandForUser2 cmd args = unwords $ map (\x -> if safe x then x else showCommandForUser x []) $ cmd : args     where         safe xs = xs /= "" && not (any bad xs)-        bad x = isSpace x || (x == '\\' && not isWindows) || x `elem` "\"\'"+        bad x = isSpace x || (x == '\\' && not isWindows) || x `elem` ("\"\'" :: String)

@@ -220,12 +220,17 @@ --   See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. type family RuleResult key -- = value --- | Define a builtin rule, passing the functions to run in the right circumstances.+-- | Before looking at this function, you should read the warnings at the top of this module.+--   This function is not often necessary in build systems.+--+--   Define a builtin rule, passing the functions to run in the right circumstances. --   The @key@ and @value@ types will be what is used by 'Development.Shake.Rule.apply'. --   As a start, you can use 'noLint' and 'noIdentity' as the first two functions, --   but are required to supply a suitable 'BuiltinRun'. -- --   Raises an error if any other rule exists at this type.+--+--   For a worked example of writing a rule see <https://tech-blog.capital-match.com/posts/5-upgrading-shake.html>. addBuiltinRule     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)     => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()

@@ -331,7 +331,7 @@ incrementStep db = runLocked db $ do     stepId <- mkId db stepKey     v <- liftIO $ getKeyValueFromId db stepId-    step<- pure $ case v of+    step <- liftIO $ evaluate $ case v of         Just (_, Loaded r) -> incStep $ fromStepResult r         _ -> Step 1     let stepRes = toStepResult step

@@ -71,7 +71,7 @@     ,"All rules will be rebuilt"]     where         limit x = let (a,b) = splitAt 200 x in a ++ (if null b then "" else "...")-        disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` "\r\n")+        disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` ("\r\n" :: String))   messageMissingTypes :: FilePath -> [String] -> [String]

@@ -207,10 +207,10 @@ type OneShot a = a  data Status-    = Ready (Result (Value, OneShot BS_Store)) -- ^ I have a value-    | Failed SomeException (OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error-    | Loaded (Result BS_Store) -- ^ Loaded from the database-    | Running (NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store)) -- ^ Currently in the process of being checked or built+    = Ready !(Result (Value, OneShot BS_Store)) -- ^ I have a value+    | Failed !SomeException !(OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error+    | Loaded !(Result BS_Store) -- ^ Loaded from the database+    | Running !(NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store)) -- ^ Currently in the process of being checked or built     | Missing -- ^ I am only here because I got into the Intern table       deriving Show @@ -227,12 +227,12 @@   data Result a = Result-    {result :: a -- ^ the result associated with the Key+    {result :: !a -- ^ the result associated with the Key     ,built :: {-# UNPACK #-} !Step -- ^ when it was actually run     ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid-    ,depends :: [Depends] -- ^ dependencies (don't run them early)+    ,depends :: ![Depends] -- ^ dependencies (don't run them early)     ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)-    ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)+    ,traces :: ![Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)     } deriving (Show,Functor)  instance NFData a => NFData (Result a) where

@@ -27,7 +27,7 @@     hasManual <- hasManualData     ghc <- isJust <$> findExecutable "ghc"     (gcc, gccPath) <- findGcc-    shakeLib <- wrap $ fmap (not . null . words . fromStdout) (cmd "ghc-pkg list --simple-output shake")+    shakeLib <- wrap $ fmap (not . null . words . fromStdout) (cmd ("ghc-pkg list --simple-output shake" :: String))     ninja <- findExecutable "ninja"     putStrLn "done\n" 

@@ -19,7 +19,7 @@ import Control.Monad.Extra import System.Directory.Extra import System.FilePath-import System.IO+import System.IO.Extra import Numeric import Development.Shake.Internal.FileInfo import General.Wait@@ -136,8 +136,11 @@             copyFileLink (useSymlink shared) file (dir </> show hash)     -- Write key after files to make sure cache is always useable     let v = runBuilder $ putEntry (keyOp shared) entry-    createDirectoryRecursive $ dir </> "_key"-    BS.writeFile (dir </> "_key" </> hexed v) v+    let dirName = dir </> "_key"+    createDirectoryRecursive dirName+    -- #757, make sure we write this file atomically+    (tempFile, cleanUp) <- newTempFileWithin dir+    (BS.writeFile tempFile v >> renameFile tempFile (dirName </> hexed v)) `onException` cleanUp   addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()

@@ -18,6 +18,7 @@ import System.Time.Extra import qualified Data.HashMap.Strict as Map import Development.Shake.Internal.FilePattern+import Development.Shake.Internal.Errors import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.UTF8 as UTF8 import Development.Shake.Internal.CmdOption@@ -285,7 +286,7 @@             | Just x <- cast x = show (x :: Hidden (Map.HashMap TypeRep Dynamic))             | Just x <- cast x = show (x :: Hidden (String -> String -> Bool -> IO ()))             | Just x <- cast x = show (x :: [CmdOption])-            | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x)+            | otherwise = throwImpure $ errorInternal $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x)  instance Show ShakeOptions where     show x = "ShakeOptions {" ++ intercalate ", " (map (\(a,b) -> a ++ " = " ++ b) $ shakeOptionsFields x) ++ "}"

@@ -41,7 +41,7 @@         (noDeps, hasDeps) = partition (null . snd) $ Map.toList status          f [] mp | null bad = []-                | otherwise = error $ unlines $+                | otherwise = throwImpure $ errorInternal $ unlines $                     "Internal invariant broken, database seems to be cyclic" :                     map ("    " ++) bad ++                     ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow]

@@ -12,7 +12,6 @@ import Development.Shake.Internal.Errors import Data.Typeable -import Data.Bits import Unsafe.Coerce  @@ -103,7 +102,8 @@     rnf Value{..} = valueRnf valueValue  instance Hashable Key where-    hashWithSalt salt Key{..} = hashWithSalt salt keyType `xor` keyHash salt keyValue+    hash Key{..} = keyHash (hash keyType) keyValue+    hashWithSalt salt Key{..} = keyHash (hashWithSalt salt keyType) keyValue  instance Eq Key where     Key{keyType=at,keyValue=a,keyEq=eq} == Key{keyType=bt,keyValue=b}

@@ -275,7 +275,7 @@   -- | Invert 'prettyCallStack', which GHC pre-applies in certain cases-parseCallStack = reverse . map trimStart . drop 1 . lines+parseCallStack = reverse . map trimStart . drop1 . lines  callStackFull = parseCallStack $ prettyCallStack $ popCallStack callStack 

@@ -99,7 +99,7 @@     let go !i | i >= used = pure ()               | otherwise = do                 v <- readArray values i-                whenJust v $ \v -> writeArray values i $ Just $ f v+                whenJust v $ \v -> writeArray values i $! Just $! f v                 go $ i+1     go 0 

@@ -100,6 +100,6 @@         resetTimings         withNumCapabilities 4 $ do             (d, _) <- duration $ runPool False 4 $ \pool ->-                replicateM_ 200000 $ addPool PoolStart pool $ return ()+                replicateM_ 200000 $ addPool PoolStart pool $ pure ()             print d             print =<< getTimings