diff --git a/Development/Shake/Composition.hs b/Development/Shake/Composition.hs index e8b33d2..c98ca54 100644 --- a/Development/Shake/Composition.hs +++ b/Development/Shake/Composition.hs @@ -99,9 +99,8 @@ instance (Namespace n1, Namespace n2) => Namespace (n1 :+: n2) where data Snapshot (n1 :+: n2) = UnionSnapshot (Snapshot n1) (Snapshot n2) takeSnapshot = liftM2 UnionSnapshot takeSnapshot takeSnapshot - compareSnapshots building_ns ns (UnionSnapshot ss1 ss2) (UnionSnapshot ss1' ss2') = compareSnapshots building_ns1 ns1 ss1 ss1' ++ compareSnapshots building_ns2 ns2 ss2 ss2' - where (ns1, ns2) = partitionNames ns - (building_ns1, building_ns2) = partitionNames building_ns + lintSnapshots building_ns sss = lintSnapshots building_ns1 [(ss1, ss1', fst (partitionNames ns)) | (UnionSnapshot ss1 _ss2, UnionSnapshot ss1' _ss2', ns) <- sss] ++ lintSnapshots building_ns2 [(ss2, ss2', snd (partitionNames ns)) | (UnionSnapshot _ss1 ss2, UnionSnapshot _ss1' ss2', ns) <- sss] + where (building_ns1, building_ns2) = partitionNames building_ns partitionNames :: [n1 :+: n2] -> ([n1], [n2]) partitionNames ns = ([n1 | LeftName n1 <- ns], [n2 | RightName n2 <- ns]) @@ -124,7 +123,7 @@ instance Namespace Empty where type Entry Empty = Empty data Snapshot Empty = EmptySnapshot takeSnapshot = return EmptySnapshot - compareSnapshots _ _ EmptySnapshot EmptySnapshot = [] + lintSnapshots _ _ = [] liftRule :: (nsub :< nsup) => Rule' ntop nsub -> Rule' ntop nsup diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs index 63bdbb1..1829a37 100644 --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -43,11 +43,12 @@ import qualified Data.ByteString.Lazy as BS import Data.Typeable (Typeable) -- For Exception only -import Control.Applicative (Applicative) +import Control.Applicative (Applicative(..)) import Control.Arrow (first, second) import Control.Concurrent.MVar -import Control.Concurrent.ParallelIO.Local +import Control.Concurrent.ParallelIO.Local (Pool) +import qualified Control.Concurrent.ParallelIO.Local as Parallel import Control.DeepSeq import qualified Control.Exception.Peel as Exception @@ -71,6 +72,7 @@ import Data.Time.Clock (UTCTime, NominalDiffTime, getCurrentTime, diffUTCTime) import Data.Foldable (traverse_) import System.Environment +import System.IO import System.IO.Unsafe (unsafePerformIO) -- For command line parsing hack only import GHC.Conc (numCapabilities) @@ -144,7 +146,11 @@ class (Ord n, Eq (Entry n), takeSnapshot :: IO (Snapshot n) - compareSnapshots :: [n] -> [n] -> Snapshot n -> Snapshot n -> [String] + lintSnapshots :: [n] -- ^ Files that the rule claims to build. An empty list if linting a top-level action. + -> [(Snapshot n, Snapshot n, [n])] -- ^ Sequence of snapshots taken just before and after running rule code, and the list of files needed by the rule code as it exits. + -- The list is in sequential order: earlier fragments of rule code make snapshot tranisitions that appear earlier in the list. + -- The last list of files will always be empty because the rule exits for the last time by returning normally rather than needing anything. + -> [String] -- ^ Rule lint errors, if any type Rule' ntop n = n -> IO (Maybe (Generator' ntop n)) @@ -291,13 +297,12 @@ instance Namespace n => Binary (QA n) where data ActState n = AS { as_this_history :: History n, - as_snapshot :: Maybe (Snapshot n) + as_snapshots :: [(Snapshot n, Snapshot n, [n])] } data ActEnv n = AE { ae_would_block_handles :: [WaitHandle ()], -- ^ A list of handles that would be incapable of awakening if the action were to -- block indefinitely here and now. This is used in the deadlock detector. - ae_building :: [n], ae_rules :: [[RuleClosure n]], ae_database :: Database n, ae_wait_database :: MVar (WaitDatabase n), @@ -307,10 +312,31 @@ data ActEnv n = AE { } -newtype Act n a = Act { unAct :: Reader.ReaderT (ActEnv n) (State.StateT (ActState n) IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) +data Act n a = Act { unAct :: forall m. (MonadLint m, LintNamespace m ~ n) => Reader.ReaderT (ActEnv n) (State.StateT (ActState n) m) a } -runAct :: ActEnv n -> ActState n -> Act n a -> IO (a, ActState n) +instance Functor (Act n) where + fmap = liftM + +instance Applicative (Act n) where + pure = return + (<*>) = ap + +instance Monad (Act n) where + return x = Act (return x) + Act mx >>= fxmy = Act $ mx >>= \x -> case fxmy x of Act it -> it + +instance MonadIO (Act n) where + liftIO io = Act (liftIO io) + +instance MonadPeelIO (Act n) where + -- Thanks to Anders Kaseorg for this definition (I added a bit of NoLint wrapping to work around the LintNamespace constraint) + peelIO = toAct (liftM (\k (Act mx) -> liftM toAct (k mx)) peelIO) + where + toAct :: Reader.ReaderT (ActEnv n) (State.StateT (ActState n) (NoLint n)) a -> Act n a + toAct mx = Act (Reader.mapReaderT (State.mapStateT (liftIO . unNoLint)) mx) + + +runAct :: (MonadLint m, LintNamespace m ~ n) => ActEnv n -> ActState n -> Act n a -> m (a, ActState n) runAct e s mx = State.runStateT (Reader.runReaderT (unAct mx) e) s -- getActState :: Act ActState @@ -333,17 +359,14 @@ putStrLnAt at_verbosity msg = do verbosity <- actVerbosity liftIO $ when (verbosity >= at_verbosity) $ putStrLn msg -liftLint :: Lint n a -> Act n a -liftLint lint = Act $ Reader.ReaderT $ \e -> State.StateT $ \s -> State.runStateT (Reader.runReaderT (unLint lint) (ae_building e, [n | Need nes <- as_this_history s, (n, _e) <- nes])) (as_snapshot s) >>= \(x, mb_ss) -> return (x, s { as_snapshot = mb_ss }) - -- NB: if you use shake in a nested way bad things will happen to parallelism -- TODO: make parallelism configurable? shake :: Namespace n => Shake n () -> IO () shake = shakeWithOptions defaultShakeOptions -shakeWithOptions :: Namespace n => ShakeOptions -> Shake n () -> IO () -shakeWithOptions opts mx = withPool (shakeThreads opts) $ \pool -> do +shakeWithOptions :: forall n. Namespace n => ShakeOptions -> Shake n () -> IO () +shakeWithOptions opts mx = Parallel.withPool (shakeThreads opts) $ \pool -> do mb_bs <- handleDoesNotExist (return Nothing) $ fmap Just $ BS.readFile ".openshake-db" db <- case mb_bs of Nothing -> do @@ -361,13 +384,24 @@ shakeWithOptions opts mx = withPool (shakeThreads opts) $ \pool -> do wdb_mvar <- newMVar emptyWaitDatabase report_mvar <- emptyReportDatabase >>= newMVar - mb_ss <- if shakeLint opts then fmap Just takeSnapshot else return Nothing - -- Collect rules and wants, then execute the collected Act actions (in any order) let ((), complete_s) = runShake (SE { se_available_rules = [ss_rules complete_s] }) (SS { ss_rules = [], ss_acts = [] }) mx - _ <- flip State.runStateT mb_ss $ parallelLint' pool $ flip map (ss_acts complete_s) $ \(act_rules, act) -> State.StateT $ \mb_ss -> do - ((), final_s) <- runAct (AE { ae_building = [], ae_would_block_handles = [], ae_rules = act_rules, ae_database = db_mvar, ae_wait_database = wdb_mvar, ae_report = report_mvar, ae_pool = pool, ae_options = opts }) (AS { as_this_history = [], as_snapshot = mb_ss }) act - return ((), as_snapshot final_s) + + -- You might think that we could lose the type signature here, and then inline mk_e into its sole use site. + -- Unfortunately, that doesn't type check properly on GHC 7.0.1.20101215 (i.e. RC2), and I have no idea why. + mk_e :: [[RuleClosure n]] -> ActEnv n + mk_e act_rules = AE { ae_would_block_handles = [], ae_rules = act_rules, ae_database = db_mvar, ae_wait_database = wdb_mvar, ae_report = report_mvar, ae_pool = pool, ae_options = opts } + + run_acts :: forall m. (MonadLint m, LintNamespace m ~ n) => m () + run_acts = void $ parallel pool $ flip map (ss_acts complete_s) $ \(act_rules, act) -> runActLinted [] (mk_e act_rules) act + + if shakeLint opts + then do + ss_mvar <- newEmptyMVar + ss <- takeSnapshot + (x, _) <- (flip State.runStateT ss . flip Reader.runReaderT ss_mvar) $ unLint' run_acts + return x + else unNoLint run_acts final_report <- takeMVar report_mvar traverse_ (\report_fp -> writeFile report_fp (produceReport final_report)) (shakeReport opts) @@ -392,7 +426,12 @@ addRule rule = do need :: Namespace n => [n] -> Act n [Entry n] need fps = do e <- askActEnv - need_times <- liftLint $ need' e fps + + need_times <- Act $ Reader.ReaderT $ \_ -> State.StateT $ \s -> do + mb_sss <- retakeSnapshot fps + need_times <- need' e fps + return (need_times, s { as_snapshots = maybe id (:) mb_sss (as_snapshots s) }) + appendHistory $ Need (fps `zip` need_times) return need_times @@ -402,7 +441,7 @@ withoutMVar mvar x act = liftIO (putMVar mvar x) >> act >>= \y -> liftIO (takeMV -- We assume that the rules do not change to include new dependencies often: this lets -- us not rerun a rule as long as it looks like the dependencies of the *last known run* -- of the rule have not changed -doesQARequireRerun :: Namespace n => ([n] -> Lint n [Entry n]) -> QA n -> Lint n (Maybe String) +doesQARequireRerun :: (Namespace n, Monad m) => ([n] -> m [Entry n]) -> QA n -> m (Maybe String) doesQARequireRerun need (Need nested_fps_times) = do let (nested_fps, nested_old_times) = unzip nested_fps_times -- NB: if this Need is for a generated file we have to build it again if any of the things *it* needs have changed, @@ -412,24 +451,70 @@ doesQARequireRerun need (Need nested_fps_times) = do \fp old_time new_time -> guard (old_time /= new_time) >> return ("modification time of " ++ show fp ++ " has changed from " ++ show old_time ++ " to " ++ show new_time) -newtype Lint n a = Lint { unLint :: Reader.ReaderT ([n], [n]) (Lint' n) a } -- If the Snapshot is empty, we aren't linting - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) +class (Functor m, Monad m, MonadIO m, MonadPeelIO m) => MonadLint m where + type LintNamespace m + parallel :: Pool -> [m a] -> m [a] + modifyMVarLint :: MVar a -> (a -> m (a, b)) -> m b + retakeSnapshot :: [LintNamespace m] -> m (Maybe (Snapshot (LintNamespace m), Snapshot (LintNamespace m), [LintNamespace m])) + liftBlockingIO :: IO a -> m a + -type Lint' n = State.StateT (Maybe (Snapshot n)) IO +newtype NoLint n a = NoLint { unNoLint :: IO a } + deriving (Functor, Monad, MonadIO, MonadPeelIO) --- If in non-linting mode, run actions in parallel. Otherwise, run them sequentially so we can validate the changes made at every step -parallelLint' :: Pool -> [Lint' n a] -> Lint' n [a] -parallelLint' pool acts = State.StateT $ \mb_s -> case mb_s of Nothing -> liftM (,Nothing) $ parallel pool $ map (\act -> liftM fst $ State.runStateT act Nothing) acts - Just s -> State.runStateT (sequence acts) (Just s) +instance MonadLint (NoLint n) where + type LintNamespace (NoLint n) = n + parallel pool = NoLint . Parallel.parallel pool . map unNoLint + modifyMVarLint mvar f = NoLint $ modifyMVar mvar (unNoLint . f) + retakeSnapshot _ = return Nothing + liftBlockingIO = liftIO -findAllRules :: Namespace n + +newtype Lint' n a = Lint' { unLint' :: Reader.ReaderT (MVar (Snapshot n)) (State.StateT (Snapshot n) IO) a } + deriving (Functor, Monad, MonadIO, MonadPeelIO) + +lintIO :: ((Lint' n a -> IO a) -> IO b) -- ^ Supplies the IO action with a way to convert Lint actions into IO actions for the duration + -> Lint' n b +lintIO f = Lint' $ Reader.ReaderT $ \ss_mvar -> State.StateT $ \ss -> do + -- Restore the most recent Snapshot to the MVar while running an outside action, in case + -- that outside IO action schedules another Lint' action that will update the current Snapshot. + putMVar ss_mvar ss + res <- f $ \lint -> modifyMVar ss_mvar (\ss -> liftM swap (State.runStateT (Reader.runReaderT (unLint' lint) ss_mvar) ss)) + -- If we scheduled another Lint action during that last call, the Snapshot will have changed. + ss <- takeMVar ss_mvar + return (res, ss) + +instance Namespace n => MonadLint (Lint' n) where + type LintNamespace (Lint' n) = n + -- My first thought was that if in non-linting mode, we could just run actions in parallel. If in linting mode, we could run them sequentially + -- so we could validate the changes made at every step. + -- + -- Unfortunately, this isn't very cool because a rule might need something that is already being built by another branch above. E.g. I could + -- need ["a", "b"], and the rule for ["a"] could need ["b"]. Now I'm screwed because the entry for "b" will be a WaitHandle, but waiting on it will + -- deadlock. + -- + -- So I still need to keep around the mechanism of parallelism in lint mode, even though I only permit one thread to run at a time. + parallel pool acts = lintIO $ \lint_to_io -> Parallel.parallel pool (map lint_to_io acts) + + modifyMVarLint mvar f = Lint' $ Reader.ReaderT $ \e -> State.StateT $ \s -> modifyMVar mvar (\x -> liftM (\((a, b), s) -> (a, (b, s))) $ State.runStateT (Reader.runReaderT (unLint' (f x)) e) s) + + retakeSnapshot fps = Lint' $ Reader.ReaderT $ \_e -> State.StateT $ \ss -> do + -- Record data so we can lint the IO done in between entering a user rule and it invoking need + ss' <- takeSnapshot + -- Rule code tranisitioned from ss to ss' before needing fps + return (Just (ss, ss', fps), ss') + + liftBlockingIO io = lintIO (const io) + + +findAllRules :: (Namespace n, MonadLint m, LintNamespace m ~ n) => ActEnv n -> [n] -- ^ The files that we wish to find rules for -> [WaitHandle ()] -- ^ Handles that would be blocked if we blocked the thread right now -> PureDatabase n - -> Lint n (PureDatabase n, - ([(n, Lint' n (Either ShakefileException (Entry n)))], -- Action that just waits for a build in progress elsewhere to complete - [([n], Lint' n (Either ShakefileException [Entry n]))])) -- Action that creates (possibly several) of the files we asked for by invoking a user rule + -> m (PureDatabase n, + ([(n, m (Either ShakefileException (Entry n)))], -- Action that just waits for a build in progress elsewhere to complete + [([n], m (Either ShakefileException [Entry n]))])) -- Action that creates (possibly several) of the files we asked for by invoking a user rule findAllRules _ [] _ db = return (db, ([], [])) findAllRules e (fp:fps) would_block_handles db = do (fps, would_block_handles, db, res_transformer) <- do @@ -441,13 +526,13 @@ findAllRules e (fp:fps) would_block_handles db = do -- We've previously discovered the file to be clean: return an action that just returns the computed entry directly Just (Clean _ mtime) -> Right $ return (Right mtime) -- Someone else is in the process of making the file clean. Return an action that wait on the wait handle for it to complete - Just (Building _ wait_mvar) -> Right $ liftIO $ do + Just (Building _ wait_mvar) -> Right $ liftBlockingIO $ do -- We can avoid a lot of fuss if the wait handle is already triggered, so there can be no waiting. -- This is purely a performance optimisation: may_wait <- mayWaitOnWaitHandle wait_mvar let wrapper | may_wait = reportWorkerBlocked (ae_report e) . registerWait (ae_wait_database e) fp (fmap (const ()) wait_mvar) (ae_would_block_handles e) . - extraWorkerWhileBlocked (ae_pool e) -- NB: We must spawn a new pool worker while we wait, or we might get deadlocked by depleting the pool of workers + Parallel.extraWorkerWhileBlocked (ae_pool e) -- NB: We must spawn a new pool worker while we wait, or we might get deadlocked by depleting the pool of workers | otherwise = id -- NB: we communicate the ModTimes of files that we were waiting on the completion of via the BuildingWaitHandle wrapper (waitOnWaitHandle wait_mvar) @@ -519,7 +604,7 @@ findAllRules e (fp:fps) would_block_handles db = do Left (clean_hist, clean_mtime) -> return ([fp], return (clean_hist, [clean_mtime])) -- NB: we checked that clean_mtime is still ok using sanityCheck above Right dirty_reason -> do when (verbosity >= ChattyVerbosity) $ liftIO $ putStrLn $ "Rebuild " ++ show fp ++ " because " ++ dirty_reason - return (potential_creates_fps, potential_rule (\rules building -> e { ae_building = building, ae_rules = rules, ae_would_block_handles = fmap (const ()) wait_handle : ae_would_block_handles e })) + return (potential_creates_fps, potential_rule (\rules -> e { ae_rules = rules, ae_would_block_handles = fmap (const ()) wait_handle : ae_would_block_handles e })) let -- It is possible that we need two different files that are both created by the same rule. This is not an error! -- What we should do is remove from the remaning uncleans any files that are created by the rule we just added @@ -559,14 +644,8 @@ findAllRules e (fp:fps) would_block_handles db = do where verbosity = shakeVerbosity (ae_options e) -modifyMVarLint :: MVar a -> (a -> Lint n (a, b)) -> Lint n b -modifyMVarLint mvar f = Lint $ Reader.ReaderT $ \e -> State.StateT $ \s -> modifyMVar mvar (\x -> liftM (\((a, b), s) -> (a, (b, s))) $ State.runStateT (Reader.runReaderT (unLint (f x)) e) s) - -need' :: Namespace n => ActEnv n -> [n] -> Lint n [Entry n] +need' :: (Namespace n, MonadLint m, LintNamespace m ~ n) => ActEnv n -> [n] -> m [Entry n] need' e init_fps = do - -- Lint the IO done in between entering a user rule and it invoking need - retakeSnapshot - -- Figure out the rules we need to use to create all the dirty files we need -- -- NB: this MVar operation does not block us because any thread only holds the database lock @@ -574,24 +653,23 @@ need' e init_fps = do -- When we have to recursively invoke need, we put back into the MVar before doing so. (cleans, uncleans) <- modifyMVarLint (ae_database e) $ findAllRules e init_fps [] - Lint $ Reader.ReaderT $ \_ -> do - -- Run the rules we have decided upon in parallel - -- - -- NB: we report that the thread using parallel is blocked because it may go on to actually - -- execute one of the parallel actions, which will bump the parallelism count without any - -- extra parallelism actually occuring. - unclean_times <- reportWorkerBlocked (ae_report e) $ parallelLint' (ae_pool e) $ flip map uncleans $ \(unclean_fps, rule) -> reportWorkerRunning (ae_report e) $ liftM (fmapEither (map show unclean_fps,) (unclean_fps `zip`)) rule - - -- For things that are being built by someone else we only do trivial work, so don't have to spawn any thread - clean_times <- forM cleans $ \(clean_fp, rule) -> liftM (fmapEither ([show clean_fp],) (\mtime -> [(clean_fp, mtime)])) rule + -- Run the rules we have decided upon in parallel + -- + -- NB: we report that the thread using parallel is blocked because it may go on to actually + -- execute one of the parallel actions, which will bump the parallelism count without any + -- extra parallelism actually occuring. + unclean_times <- reportWorkerBlocked (ae_report e) $ parallel (ae_pool e) $ flip map uncleans $ \(unclean_fps, rule) -> reportWorkerRunning (ae_report e) $ liftM (fmapEither (map show unclean_fps,) (unclean_fps `zip`)) rule + + -- For things that are being built by someone else we only do trivial work, so don't have to spawn any thread + clean_times <- forM cleans $ \(clean_fp, rule) -> liftM (fmapEither ([show clean_fp],) (\mtime -> [(clean_fp, mtime)])) rule - -- Gather up any failures experienced in recursive needs, and the modtimes for files that were built succesfully - let (failures, all_timess) = partitionEithers $ unclean_times ++ clean_times - ([], reordered_times) = fromRight (\fp -> internalError $ "A call to need' didn't return a modification time for the input file " ++ show fp) $ lookupRemoveMany init_fps (concat all_timess) + -- Gather up any failures experienced in recursive needs, and the modtimes for files that were built succesfully + let (failures, all_timess) = partitionEithers $ unclean_times ++ clean_times + ([], reordered_times) = fromRight (\fp -> internalError $ "A call to need' didn't return a modification time for the input file " ++ show fp) $ lookupRemoveMany init_fps (concat all_timess) - if null failures - then return reordered_times - else liftIO $ Exception.throwIO $ RecursiveError failures + if null failures + then return reordered_times + else liftIO $ Exception.throwIO $ RecursiveError failures -- | Just a unique number to identify each update we make to the 'WaitDatabase' type WaitNumber = Int @@ -753,9 +831,9 @@ updateStatus db_mvar fp_statuses = modifyMVar_ db_mvar (return . go) appendHistory :: QA n -> Act n () appendHistory extra_qa = modifyActState $ \s -> s { as_this_history = as_this_history s ++ [extra_qa] } -findRule :: Namespace n +findRule :: (Namespace n, MonadLint m, LintNamespace m ~ n) => Verbosity -> [[RuleClosure n]] -> n - -> IO ([n], ([[RuleClosure n]] -> [n] -> ActEnv n) -> Lint' n (History n, [Entry n])) + -> IO ([n], ([[RuleClosure n]] -> ActEnv n) -> m (History n, [Entry n])) findRule verbosity ruless fp = do possibilities <- flip mapMaybeM ruless $ \rules -> do generators <- mapMaybeM (\rc -> liftM (fmap ((,) (rc_closure rc))) $ rc_rule rc fp) rules @@ -773,15 +851,13 @@ findRule verbosity ruless fp = do Nothing -> shakefileError $ "No rule to build " ++ show fp Just generator -> return $ ([], generator) -- TODO: generalise to allow default rules to refer to others? - return (creates_fps, \mk_e -> State.StateT $ \mb_ss -> do - -- Lint the IO stuff that the rule did in between its last invocation of need (if any) and returning - (creates_times, final_nested_s) <- runAct (mk_e clo_rules creates_fps) (AS { as_this_history = [], as_snapshot = mb_ss }) (action `tap_` liftLint retakeSnapshot) - return ((as_this_history final_nested_s, creates_times), as_snapshot final_nested_s)) - -retakeSnapshot :: Namespace n => Lint n () -retakeSnapshot = Lint $ Reader.ReaderT $ \(building_ns, ns) -> State.StateT $ \mb_ss -> case mb_ss of Nothing -> return ((), Nothing) - Just ss -> do - ss' <- takeSnapshot - -- FIXME: accumulate errors - mapM_ putStrLn $ compareSnapshots building_ns ns ss ss' - return ((), Just ss') + return (creates_fps, \mk_e -> runActLinted creates_fps (mk_e clo_rules) action) + +runActLinted :: (Namespace n, MonadLint m, LintNamespace m ~ n) => [n] -> ActEnv n -> Act n a -> m (History n, a) +runActLinted creates_fps e action = do + (res, final_nested_s) <- runAct e (AS { as_this_history = [], as_snapshots = [] }) action + -- User code transitioned from ss to ss' before returning without needing anything else + mb_sss <- retakeSnapshot [] + -- FIXME: accumulate errors rather than showing them eagerly like this + liftIO $ mapM_ (hPutStrLn stderr) $ lintSnapshots creates_fps (reverse $ maybe id (:) mb_sss (as_snapshots final_nested_s)) + return (as_this_history final_nested_s, res) diff --git a/Development/Shake/Files.hs b/Development/Shake/Files.hs index 18d52ff..114e6e0 100644 --- a/Development/Shake/Files.hs +++ b/Development/Shake/Files.hs @@ -116,7 +116,7 @@ instance Namespace CanonicalFilePath where -- check will catch the change. Just nested_time -> return $ Just ([fp], return [nested_time]) -- TODO: distinguish between files created b/c of rule match and b/c they already exist in history? Lets us rebuild if the reason changes. - data Snapshot CanonicalFilePath = CFPSS (M.Map CanonicalFilePath ClockTime) + data Snapshot CanonicalFilePath = CFPSS { unCFPSS :: M.Map CanonicalFilePath ClockTime } takeSnapshot = do cwd <- getCurrentDirectory >>= canonical @@ -134,20 +134,29 @@ instance Namespace CanonicalFilePath where then return (seen', S.insert fp seen_files) else getDirectoryContents (canonicalFilePath fp) >>= (foldM (explore fp) (seen', seen_files) . map (originalFilePath fp )) - compareSnapshots building_fps needed_fps (CFPSS ss) (CFPSS ss') = [show fp ++ " was " ++ reason ++ " without 'need'ing it" | (fp, reason) <- accessed_no_need] + -- TODO: I could lint modification times as well? For example, you should probably not modify a file you need + lintSnapshots building_fps = go S.empty S.empty S.empty where - (ss_deleted, ss_continued, _ss_created) = zipMaps ss ss' - ss_accessed = M.filter (\(atime1, atime2) -> atime1 < atime2) ss_continued - - -- 1) We must not be allowed to access/delete files that we didn't "need" or are building - accessed_no_need = filter (\(fp, _reason) -> not $ fp `elem` (building_fps ++ needed_fps)) (map (,"deleted") (M.keys ss_deleted) ++ map (,"read or written to") (M.keys ss_accessed)) - -- 2) We should not "need" files that we didn't access - -- FIXME: I shouldn't be doing this until the very last need.. - --needed_no_access = filter (\fp -> not $ fp `M.member` ss_accessed) fps - -- 3) We must not create files there are rules for but are not in our "also" list - -- FIXME - -- 4) We should not delete files there are rules for, even if we previously "need"ed them - -- FIXME + go needed accessed accessed_without_need history = case history of + [] -> [show fp ++ " was accessed without 'need'ing it first" | fp <- S.toList (accessed_without_need S.\\ S.fromList building_fps)] ++ + [show fp ++ " was 'need'ed without ever being accessed" | not (null building_fps), fp <- S.toList needed_without_access] + -- It is OK to need something "uselessly" at the top level, hence the check against building_fps here + where -- 2) We should not "need" files that we never access + needed_without_access = needed S.\\ accessed + ((ss, ss', needs):history') -> go -- a) In the successor, it is now OK to access anything we just "need"ed + (needed `S.union` S.fromList needs) + -- b) In the successor, we need not warn about over-needing those things we have just accessed + (accessed `S.union` accesses) + -- 1) We should not be allowed to access files that we didn't "need" or are building + (accessed_without_need `S.union` (accesses S.\\ needed)) + history' + where + (_ss_deleted, ss_continued, _ss_created) = zipMaps (unCFPSS ss) (unCFPSS ss') + accesses = M.keysSet $ M.filter (\(atime1, atime2) -> atime1 < atime2) ss_continued + -- 3) We should not create files there are rules for but are not in our "also" list + -- FIXME + -- 4) We should not delete files there are rules for + -- FIXME zipMaps :: Ord k => M.Map k v -> M.Map k v -> (M.Map k v, M.Map k (v, v), M.Map k v) diff --git a/Development/Shake/Oracles/Common.hs b/Development/Shake/Oracles/Common.hs index 34c07b6..777b662 100644 --- a/Development/Shake/Oracles/Common.hs +++ b/Development/Shake/Oracles/Common.hs @@ -42,7 +42,7 @@ instance Oracle o => Namespace (Question o) where data Snapshot (Question o) = OracleSnapshot -- Nothing to sanity check: how could we tell if user code had used the result of a query? takeSnapshot = return OracleSnapshot - compareSnapshots _ _ OracleSnapshot OracleSnapshot = [] + lintSnapshots _ _ = [] oracleRule :: Oracle o => o -> Question o -> IO (Maybe ([Question o], Act ntop [Answer o])) diff --git a/tests/Test.lhs b/tests/Test.lhs index b945c58..bcf4ff7 100755 --- a/tests/Test.lhs +++ b/tests/Test.lhs @@ -45,10 +45,16 @@ seconds = (*1000000) traceShowM :: (Monad m, Show a) => m a -> m a traceShowM mx = mx >>= \x -> trace (show x) (return x) +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + assertEqualM :: (Eq a, Show a, Monad m) => a -> a -> m () assertEqualM expected actual = if expected == actual then return () else fail $ show expected ++ " /= " ++ show actual +assertEqualFileM :: FilePath -> String -> IO () +assertEqualFileM fp_expected actual = readFile fp_expected >>= \expected -> assertEqualM expected actual + assertIsM :: (Show a, Monad m) => (a -> Bool) -> a -> m () assertIsM expectation actual = if expectation actual then return () else fail $ show actual ++ " did not match our expectations" @@ -64,17 +70,17 @@ timeoutForeign microsecs cleanup act = flip Exception.finally cleanup $ do timeout microsecs $ takeMVar mvar shake_ :: FilePath -> [String] -> IO ExitCode -shake_ fp args = fmap fst $ shake fp args +shake_ fp args = fmap fst3 $ shake fp args -shake :: FilePath -> [String] -> IO (ExitCode, String) -shake fp args = do +shake :: FilePath -> [String] -> IO (ExitCode, String, String) +shake fp args = {- (\res@(ec, stdout, stderr) -> putStrLn stdout >> putStrLn stderr >> return res) =<< -} do extra_args <- getArgs -- NB: this is a bit of a hack! - (_h_stdin, _h_stdout, h_stderr, ph) <- runInteractiveProcess "runghc" (["-i../../", fp] ++ args ++ extra_args) Nothing Nothing - mb_ec <- timeoutForeign (seconds 5) (terminateProcess ph) $ waitForProcess ph + (_h_stdin, h_stdout, h_stderr, ph) <- runInteractiveProcess "runghc" (["-i../../", fp] ++ args ++ extra_args) Nothing Nothing + mb_ec <- timeoutForeign (seconds 10) (terminateProcess ph) $ waitForProcess ph case mb_ec of Nothing -> error "shake took too long to run!" - Just ec -> fmap ((,) ec) $ hGetContents h_stderr + Just ec -> liftM2 ((,,) ec) (hGetContents h_stdout) (hGetContents h_stderr) -- | Shake can only detect changes that are reflected by changes to the modification time. -- Thus if we expect a rebuild we need to wait for the modification time used by the system to actually change. @@ -104,19 +110,24 @@ mtimeSanityCheck = flip Exception.finally (removeFileIfExists "delete-me") $ do True `assertEqualM` (mtime1 /= mtime2 && mtime2 /= mtime3 && mtime1 /= mtime3) +withTest :: FilePath -> [FilePath] -> IO a -> IO a +withTest dir clean_fps act = do + putStr $ dir ++ ": " + res <- withCurrentDirectory dir $ do + clean (".openshake-db":clean_fps) + act + putStrLn "[OK]" + return res + main :: IO () main = do mtimeSanityCheck - withCurrentDirectory "lexical-scope" $ do - clean [".openshake-db", "examplefile"] - + withTest "lexical-scope" ["examplefile"] $ do ec <- shake_ "Shakefile.hs" [] ExitSuccess `assertEqualM` ec - withCurrentDirectory "simple-c" $ do - clean [".openshake-db", "Main", "main.o", "constants.h"] - + withTest "simple-c" ["Main", "main.o", "constants.h"] $ do -- 1) Try a normal build. The first time around is a clean build, the second time we -- have to rebuild even though we already have Main: forM_ [42, 43] $ \constant -> do @@ -145,9 +156,7 @@ main = do -- TODO: test that nothing goes wrong if we change the type of oracle between runs - withCurrentDirectory "deserialization-changes" $ do - clean [".openshake-db", "examplefile"] - + withTest "deserialization-changes" ["examplefile"] $ do -- 1) First run has no database, so it is forced to create the file ec <- shake_ "Shakefile-1.hs" [] ExitSuccess `assertEqualM` ec @@ -169,29 +178,21 @@ main = do x <- readFile "examplefile" "OK3" `assertEqualM` x - withCurrentDirectory "cyclic" $ do - clean [".openshake-db"] - + withTest "cyclic" [] $ do ec <- shake_ "Shakefile.hs" [] isExitFailure `assertIsM` ec - withCurrentDirectory "cyclic-harder" $ do - clean [".openshake-db"] - + withTest "cyclic-harder" [] $ do ec <- shake_ "Shakefile.hs" [] isExitFailure `assertIsM` ec - withCurrentDirectory "creates-directory-implicitly" $ do - clean [".openshake-db", "subdirectory" "foo"] - + withTest "creates-directory-implicitly" ["subdirectory" "foo"] $ do -- Even though our rule does not create the directory it is building into it should succeed ec <- shake_ "Shakefile.hs" [] ExitSuccess `assertEqualM` ec - withCurrentDirectory "lazy-exceptions" $ do - clean [".openshake-db", "foo-dependency3"] - - (ec, stderr) <- shake "Shakefile.hs" ["-k"] + withTest "lazy-exceptions" ["foo-dependency3"] $ do + (ec, _stdout, stderr) <- shake "Shakefile.hs" ["-k"] -- All exceptions should be reported isExitFailure `assertIsM` ec @@ -200,13 +201,11 @@ main = do -- We should have managed to build one of the things needed even though everything else died doesFileExist "foo-dependency3" >>= assertEqualM True - withCurrentDirectory "lint" $ do - clean [".openshake-db", "access-without-need", "access-before-need", "need-without-access"] - - (ec, stderr) <- shake "Shakefile.hs" ["--lint"] + withTest "lint" ["access-without-need", "access-before-need", "need-without-access"] $ do + (ec, _stdout, stderr) <- shake "Shakefile.hs" ["--lint"] -- All exceptions should be reported ExitSuccess `assertEqualM` ec - (\x -> all (`isInfixOf` x) ["access-without-need was accessed without 'need'ing it", "access-before-need was accessed without 'need'ing it"]) `assertIsM` stderr + "lint.stderr" `assertEqualFileM` stderr \end{code} \ No newline at end of file diff --git a/tests/lint/lint.stderr b/tests/lint/lint.stderr new file mode 100644 index 0000000..de49fb0 --- /dev/null +++ b/tests/lint/lint.stderr @@ -0,0 +1,3 @@ +./accessed-without-need was accessed without 'need'ing it first +./accessed-before-need was accessed without 'need'ing it first +dummy-file was 'need'ed without ever being accessed