shake 0.17.1 → 0.17.2
raw patch · 7 files changed
+81/−59 lines, 7 files
Files
- CHANGES.txt +2/−0
- shake.cabal +1/−1
- src/Development/Shake/Internal/Core/Action.hs +5/−0
- src/Development/Shake/Internal/Core/Build.hs +9/−7
- src/Development/Shake/Internal/Rules/File.hs +59/−50
- src/Test/Batch.hs +4/−0
- src/Test/Docs.hs +1/−1
CHANGES.txt view
@@ -1,5 +1,7 @@ Changelog for Shake (* = breaking change) +0.17.2, released 2018-11-29+ Make needHasChanged work even between runs 0.17.1, released 2018-11-14 Add actionCatch, to catch exceptions in Action #622, avoid potential maxBound overflow in batch
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: shake-version: 0.17.1+version: 0.17.2 license: BSD3 license-file: LICENSE category: Development, Shake
src/Development/Shake/Internal/Core/Action.hs view
@@ -17,6 +17,7 @@ -- Internal only producesUnchecked, producesCheck, lintCurrentDirectory, blockApply, unsafeAllowApply, shakeException, lintTrackFinished,+ getCurrentKey ) where import Control.Exception@@ -536,3 +537,7 @@ deprioritize x = do (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ return () Action $ modifyRW $ addDiscount wait+++getCurrentKey :: Action (Maybe Key)+getCurrentKey = Action $ topStack . localStack <$> getRW
src/Development/Shake/Internal/Core/Build.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-} module Development.Shake.Internal.Core.Build(- getDatabaseValue,+ getDatabaseValue, getDatabaseValueGeneric, historyIsEnabled, historySave, historyLoad, apply, apply1, ) where@@ -80,14 +80,16 @@ --------------------------------------------------------------------- -- QUERIES -getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Either BS.ByteString value))-getDatabaseValue k = do+getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Result (Either BS.ByteString value)))+getDatabaseValue k =+ fmap (fmap $ fmap $ fmap fromValue) $ getDatabaseValueGeneric $ newKey k++getDatabaseValueGeneric :: Key -> Action (Maybe (Result (Either BS.ByteString Value)))+getDatabaseValueGeneric k = do Global{..} <- Action getRO Just (_, status) <- liftIO $ runLocked globalDatabase $ \database ->- getIdKeyStatus database =<< getKeyId database (newKey k)- return $ case getResult status of- Just r -> Just $ fromValue <$> result r- _ -> Nothing+ getIdKeyStatus database =<< getKeyId database k+ return $ getResult status ---------------------------------------------------------------------
src/Development/Shake/Internal/Rules/File.hs view
@@ -25,7 +25,7 @@ import General.Binary import General.Extra -import Development.Shake.Internal.Core.Types hiding (Result, result)+import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Core.Build import Development.Shake.Internal.Core.Action@@ -60,11 +60,9 @@ deriving (Typeable) -- | Result of a File rule, may contain raw file information and whether the rule did run this build-data FileR = FileR { result :: !(Maybe FileA) -- ^ Raw information about the file built by this rule.+data FileR = FileR { answer :: !(Maybe FileA) -- ^ Raw information about the file built by this rule. -- Set to 'Nothing' to prevent linting some times. , useLint :: !Bool -- ^ Should we lint the resulting file- , hasChanged :: !Bool -- ^ Whether the file changed this build. Transient- -- information, that doesn't get serialized. } deriving (Typeable) @@ -75,10 +73,10 @@ | ModeForward (Action (Maybe FileA)) -- ^ An action that looks up a file someone else produced -- | The results of the various 'Mode' rules.-data Result- = ResultPhony- | ResultDirect Ver FileA- | ResultForward Ver FileA+data Answer+ = AnswerPhony+ | AnswerDirect Ver FileA+ | AnswerForward Ver FileA -- | The file rules we use, first is the name (as pretty as you can get). data FileRule = FileRule String (FilePath -> Maybe Mode)@@ -98,13 +96,13 @@ rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData FileR where- rnf (FileR a b c) = rnf a `seq` rnf b `seq` rnf c+ rnf (FileR a b) = rnf a `seq` rnf b instance Show FileA where show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}" instance Show FileR where- show FileR{..} = show result ++ if hasChanged then " recomputed" else " not recomputed"+ show FileR{..} = show answer instance Storable FileA where sizeOf _ = 4 * 3 -- 4 Word32's@@ -120,19 +118,19 @@ putEx = putExStorableList getEx = getExStorableList -fromResult :: Result -> Maybe FileA-fromResult ResultPhony = Nothing-fromResult (ResultDirect _ x) = Just x-fromResult (ResultForward _ x) = Just x+fromAnswer :: Answer -> Maybe FileA+fromAnswer AnswerPhony = Nothing+fromAnswer (AnswerDirect _ x) = Just x+fromAnswer (AnswerForward _ x) = Just x -instance BinaryEx Result where- putEx ResultPhony = mempty- putEx (ResultDirect ver x) = putExStorable ver <> putEx x- putEx (ResultForward ver x) = putEx (0 :: Word8) <> putExStorable ver <> putEx x+instance BinaryEx Answer where+ putEx AnswerPhony = mempty+ putEx (AnswerDirect ver x) = putExStorable ver <> putEx x+ putEx (AnswerForward ver x) = putEx (0 :: Word8) <> putExStorable ver <> putEx x getEx x = case BS.length x of- 0 -> ResultPhony- i -> if i == sz then f ResultDirect x else f ResultForward $ BS.tail x+ 0 -> AnswerPhony+ i -> if i == sz then f AnswerDirect x else f AnswerForward $ BS.tail x where sz = sizeOf (undefined :: Ver) + sizeOf (undefined :: FileA) f ctor x = let (a,b) = binarySplit x in ctor a $ getEx b@@ -194,7 +192,7 @@ addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts) ruleLint :: ShakeOptions -> BuiltinLint FileQ FileR-ruleLint opts k (FileR (Just v) True _) = do+ruleLint opts k (FileR (Just v) True) = do now <- fileStoredValue opts k return $ case now of Nothing -> Just "<missing>"@@ -204,12 +202,12 @@ ruleIdentity :: ShakeOptions -> BuiltinIdentity FileQ FileR ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure errorNoHash-ruleIdentity _ = \k v -> case result v of+ruleIdentity _ = \k v -> case answer v of Just (FileA _ size hash) -> runBuilder $ putExStorable size <> putExStorable hash Nothing -> throwImpure $ errorInternal $ "File.ruleIdentity has no result for " ++ show k ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR-ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Result) mode = do+ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Answer) mode = do -- for One, rebuild makes perfect sense -- for Forward, we expect the child will have already rebuilt - Rebuild just lets us deal with code changes -- for Phony, it doesn't make that much sense, but probably isn't harmful?@@ -236,18 +234,18 @@ now <- liftIO $ fileStoredValue opts o case now of Nothing -> rebuild- Just now -> do alwaysRerun; retNew ChangedStore $ ResultDirect (Ver 0) now+ Just now -> do alwaysRerun; retNew ChangedStore $ AnswerDirect (Ver 0) now {- _ | r == RebuildNever -> do now <- liftIO $ fileStoredValue opts o case now of Nothing -> rebuild Just now -> do- let diff | Just (ResultDirect old) <- old, fileEqualValue opts old now /= NotEqual = ChangedRecomputeSame+ let diff | Just (AnswerDirect old) <- old, fileEqualValue opts old now /= NotEqual = ChangedRecomputeSame | otherwise = ChangedRecomputeDiff- retNew diff $ ResultDirect now+ retNew diff $ AnswerDirect now -}- Just (ResultDirect ver old) | mode == RunDependenciesSame, verEq ver -> do+ Just (AnswerDirect ver old) | mode == RunDependenciesSame, verEq ver -> do now <- liftIO $ fileStoredValue opts o let noHash (FileA _ _ x) = isNoFileHash x case now of@@ -259,57 +257,57 @@ EqualCheap | if noHash old then shakeChange == ChangeModtimeAndDigestInput || noHash now else True -> retOld ChangedNothing _ ->- retNew ChangedStore $ ResultDirect ver now- Just (ResultForward ver _) | verEq ver, mode == RunDependenciesSame -> retOld ChangedNothing+ retNew ChangedStore $ AnswerDirect ver now+ Just (AnswerForward ver _) | verEq ver, mode == RunDependenciesSame -> retOld ChangedNothing _ -> rebuild where -- no need to lint check forward files -- but more than that, it goes wrong if you do, see #427- fileR (ResultDirect _ x) = FileR (Just x) True- fileR (ResultForward _ x) = FileR (Just x) False- fileR ResultPhony = FileR Nothing False+ fileR (AnswerDirect _ x) = FileR (Just x) True+ fileR (AnswerForward _ x) = FileR (Just x) False+ fileR AnswerPhony = FileR Nothing False unLint (RunResult a b c) = RunResult a b c{useLint = False} - retNew :: RunChanged -> Result -> Action (RunResult FileR)- retNew c v = return $ RunResult c (runBuilder $ putEx v) $ fileR v (c == ChangedRecomputeDiff)+ retNew :: RunChanged -> Answer -> Action (RunResult FileR)+ retNew c v = return $ RunResult c (runBuilder $ putEx v) $ fileR v retOld :: RunChanged -> Action (RunResult FileR)- retOld c = return $ RunResult c (fromJust oldBin) $ fileR (fromJust old) False+ retOld c = return $ RunResult c (fromJust oldBin) $ fileR (fromJust old) -- actually run the rebuild rebuildWith act = do let answer ctor new = do let b = case () of _ | Just old <- old- , Just old <- fromResult old+ , Just old <- fromAnswer old , fileEqualValue opts old new /= NotEqual -> ChangedRecomputeSame _ -> ChangedRecomputeDiff retNew b $ ctor new case act of Nothing -> do new <- liftIO $ storedValueError opts True "Error, file does not exist and no rule available:" o- answer (ResultDirect $ Ver 0) $ fromJust new+ answer (AnswerDirect $ Ver 0) $ fromJust new Just (ver, ModeForward act) -> do new <- act case new of Nothing -> do alwaysRerun- retNew ChangedRecomputeDiff ResultPhony- Just new -> answer (ResultForward $ Ver ver) new+ retNew ChangedRecomputeDiff AnswerPhony+ Just new -> answer (AnswerForward $ Ver ver) new Just (ver, ModeDirect act) -> do cache <- historyLoad ver case cache of Just encodedHash -> do Just (FileA mod size _) <- liftIO $ storedValueError opts False "Error, restored the rule but did not produce file:" o- answer (ResultDirect $ Ver ver) $ FileA mod size $ getExStorable encodedHash+ answer (AnswerDirect $ Ver ver) $ FileA mod size $ getExStorable encodedHash Nothing -> do act new <- liftIO $ storedValueError opts False "Error, rule finished running but did not produce file:" o case new of- Nothing -> retNew ChangedRecomputeDiff ResultPhony+ Nothing -> retNew ChangedRecomputeDiff AnswerPhony Just new@(FileA _ _ fileHash) -> do producesUnchecked [xStr]- res <- answer (ResultDirect $ Ver ver) new+ res <- answer (AnswerDirect $ Ver ver) new historySave ver $ runBuilder $ if isNoFileHash fileHash then throwImpure errorNoHash else putExStorable fileHash return res@@ -320,7 +318,7 @@ -- so insert a fake dependency that cuts the process dead. alwaysRerun act- retNew ChangedRecomputeDiff ResultPhony+ retNew ChangedRecomputeDiff AnswerPhony apply_ :: Partial => (a -> FileName) -> [a] -> Action [FileR]@@ -335,10 +333,10 @@ resultHasChanged file = do let filename = FileQ $ fileNameFromString file res <- getDatabaseValue filename- old <- return $ case res of+ old <- return $ case result <$> res of Nothing -> Nothing- Just (Left bs) -> fromResult $ getEx bs- Just (Right v) -> result v+ Just (Left bs) -> fromAnswer $ getEx bs+ Just (Right v) -> answer v case old of Nothing -> return True Just old -> do@@ -378,7 +376,7 @@ need = withFrozenCallStack $ void . apply_ fileNameFromString --- | Like 'need' but returns a list of rebuild dependencies this build.+-- | Like 'need' but returns a list of rebuilt dependencies since the calling rule last built successfully. -- -- The following example writes a list of changed dependencies to a file as its action. --@@ -397,9 +395,20 @@ -- To detect the latter case you may wish to use 'resultHasChanged'. needHasChanged :: Partial => [FilePath] -> Action [FilePath] needHasChanged paths = withFrozenCallStack $ do- res <- apply_ fileNameFromString paths- return [a | (a,b) <- zip paths res, hasChanged b]+ apply_ fileNameFromString paths+ self <- getCurrentKey+ selfVal <- case self of+ Nothing -> return Nothing+ Just self -> getDatabaseValueGeneric self+ case selfVal of+ Nothing -> return paths -- never build before or not a key, so everything has changed+ Just selfVal -> flip filterM paths $ \path -> do+ pathVal <- getDatabaseValue (FileQ $ fileNameFromString path)+ return $ case pathVal of+ Just pathVal | changed pathVal > built selfVal -> True+ _ -> False + needBS :: Partial => [BS.ByteString] -> Action () needBS = withFrozenCallStack $ void . apply_ fileNameFromByteString @@ -423,7 +432,7 @@ pre <- liftIO $ mapM (fileStoredValue opts . FileQ) xs post <- apply_ id xs let bad = [ (x, if isJust a then "File change" else "File created")- | (x, a, FileR (Just b) _ _) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual]+ | (x, a, FileR (Just b) _) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual] case bad of [] -> return () (file,msg):_ -> throwM $ errorStructured
src/Test/Batch.hs view
@@ -64,6 +64,10 @@ writeFile "ABn.txt" "bogus" build ["ABn.txt", "--sleep"] assertContents "ABn.txt" ""+ writeFile "Bn.txt" "1"+ build ["Bn.txt", "--sleep"]+ build ["ABn.txt"]+ assertContents "ABn.txt" "Bn.txt\n" forM_ [[],["--usepredicate"]] $ \args -> do writeFile "An.in" "1"
src/Test/Docs.hs view
@@ -49,7 +49,7 @@ needSource trackAllow ["dist//*"] dist <- liftIO $ canonicalizePath "dist"- cmd (Cwd root) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist]+ cmd (RemEnv "GHC_PACKAGE_PATH") (Cwd root) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist] "Part_*.hs" %> \out -> do need [root </> "src/Test/Docs.hs"] -- so much of the generator is in this module