diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -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 diff --git a/src/Development/Shake/Internal/Core/Action.hs b/src/Development/Shake/Internal/Core/Action.hs --- a/src/Development/Shake/Internal/Core/Action.hs +++ b/src/Development/Shake/Internal/Core/Action.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs --- a/src/Development/Shake/Internal/Core/Build.hs +++ b/src/Development/Shake/Internal/Core/Build.hs @@ -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 --------------------------------------------------------------------- diff --git a/src/Development/Shake/Internal/Rules/File.hs b/src/Development/Shake/Internal/Rules/File.hs --- a/src/Development/Shake/Internal/Rules/File.hs +++ b/src/Development/Shake/Internal/Rules/File.hs @@ -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 "" @@ -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 diff --git a/src/Test/Batch.hs b/src/Test/Batch.hs --- a/src/Test/Batch.hs +++ b/src/Test/Batch.hs @@ -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" diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -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