diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -44,12 +44,13 @@ ,shakeVerbosity :: Verbosity -- ^ What messages to print out (defaults to 'Normal'). ,shakeStaunch :: Bool -- ^ Operate in staunch mode, where building continues even after errors (defaults to 'False'). ,shakeDump :: Bool -- ^ Dump all profiling information to 'shakeFiles' plus the extension @.js@ (defaults to 'False'). + ,shakeLint :: Bool -- ^ Perform basic sanity checks after building. } deriving (Show, Eq, Ord) -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions -shakeOptions = ShakeOptions ".shake" 1 1 Normal False False +shakeOptions = ShakeOptions ".shake" 1 1 Normal False False False -- | All forseen exception conditions thrown by Shake, such problems with the rules or errors when executing @@ -237,10 +238,15 @@ when (shakeVerbosity >= Quiet) $ output msg Right _ -> return () + let stored = createStored rs + let execute = createExecute rs withDatabase logger shakeFiles shakeVersion $ \database -> do runPool shakeThreads $ \pool -> do - let s0 = S database pool start (createStored rs) (createExecute rs) output shakeVerbosity [] [] 0 [] + let s0 = S database pool start stored execute output shakeVerbosity [] [] 0 [] mapM_ (addPool pool . staunch . wrapStack [] . runAction s0) (actions rs) + when shakeLint $ do + checkValid database stored + when (shakeVerbosity >= Loud) $ output "Lint checking succeeded" when shakeDump $ do json <- showJSON database writeFile (shakeFiles ++ ".js") $ "var shake =\n" ++ json @@ -320,7 +326,7 @@ let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2) evaluate $ rnf ans return ans - res <- liftIO $ eval (pool s) (database s) (Ops (stored s) exec) ks + res <- liftIO $ build (pool s) (database s) (Ops (stored s) exec) ks case res of Left err -> throw err Right (d, vs) -> do diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs --- a/Development/Shake/Database.hs +++ b/Development/Shake/Database.hs @@ -10,8 +10,8 @@ module Development.Shake.Database( Time, startTime, Duration, duration, Trace, Database, withDatabase, - Ops(..), eval, - allEntries, showJSON, + Ops(..), build, + allEntries, showJSON, checkValid, ) where import Development.Shake.Binary @@ -102,9 +102,7 @@ = Ready Result -- I have a value | Error SomeException -- I have been run and raised an error | Loaded Result -- Loaded from the database - | Dirty (Maybe Result) -- One of my dependents is in Error or Dirty - | Checking Pending Result -- Currently checking if I am valid - | Building Pending (Maybe Result) -- Currently building + | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building deriving Show data Result = Result @@ -116,30 +114,51 @@ ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run) } deriving Show + newtype Pending = Pending (IORef (IO ())) -- you must run this action when you finish, while holding DB lock - -- after you have set the result to Error, Ready or Dirty (checking only) - -addPending :: Pending -> IO () -> IO () -addPending (Pending p) act = modifyIORef p (>> act) + -- after you have set the result to Error or Ready instance Show Pending where show _ = "Pending" +isError Error{} = True; isError _ = False +isWaiting Waiting{} = True; isWaiting _ = False +isReady Ready{} = True; isReady _ = False + + +-- All the waiting operations are only valid when isWaiting +type Waiting = Status + +afterWaiting :: Waiting -> IO () -> IO () +afterWaiting (Waiting (Pending p) _) act = modifyIORef p (>> act) + +newWaiting :: Maybe Result -> IO Waiting +newWaiting r = do ref <- newIORef $ return (); return $ Waiting (Pending ref) r + +runWaiting :: Waiting -> IO () +runWaiting (Waiting (Pending p) _) = join $ readIORef p + +-- Wait for a set of actions to complete +-- If the action returns True, the function will not be called again +-- If the first argument is True, the thing is ended +waitFor :: [(a, Waiting)] -> (Bool -> a -> IO Bool) -> IO () +waitFor ws@(_:_) act = do + todo <- newIORef $ length ws + forM_ ws $ \(k,w) -> afterWaiting w $ do + t <- readIORef todo + when (t /= 0) $ do + b <- act (t == 1) k + writeIORef todo $ if b then 0 else t - 1 + + getResult :: Status -> Maybe Result getResult (Ready r) = Just r getResult (Loaded r) = Just r -getResult (Checking _ r) = Just r -getResult (Dirty r) = r -getResult (Building _ r) = r +getResult (Waiting _ r) = r getResult _ = Nothing -getPending :: Status -> Maybe Pending -getPending (Checking p _) = Just p -getPending (Building p _) = Just p -getPending _ = Nothing - --------------------------------------------------------------------- -- OPERATIONS @@ -152,42 +171,24 @@ -- | Return either an exception (crash), or (how much time you spent waiting, the value) -eval :: Pool -> Database -> Ops -> [Key] -> IO (Either SomeException (Duration,[Value])) -eval pool Database{..} Ops{..} ks = +build :: Pool -> Database -> Ops -> [Key] -> IO (Either SomeException (Duration,[Value])) +build pool Database{..} Ops{..} ks = join $ withLock lock $ do - vs <- mapM (evalRECB []) ks + vs <- mapM (reduce []) ks let errs = [e | Error e <- vs] if all isReady vs then return $ return $ Right (0, [value r | Ready r <- vs]) else if not $ null errs then return $ return $ Left $ head errs else do - let cb = filter (isCheckingBuilding . snd) $ zip ks vs wait <- newBarrier - todo <- newIORef $ Just $ length cb - forM_ cb $ \(k,v) -> do - let act = do - t <- readIORef todo - when (isJust t) $ do - s <- readIORef status - case Map.lookup k s of - Just (Error e) -> do - writeIORef todo Nothing - signalBarrier wait $ Left e - Just (Dirty r) -> do - Building p _ <- evalB [] k r - addPending p act -- try again - Just (Building p _) -> - -- can only happen if two people are waiting on the same Dirty - -- the first gets kicked, and sets it to Building, meaning the second sees Building - -- very subtle! - addPending p act - Just Ready{} | fromJust t == 1 -> do - writeIORef todo Nothing - signalBarrier wait $ Right [value r | k <- ks, let Ready r = fromJust $ Map.lookup k s] - Just Ready{} -> - writeIORef todo $ fmap (subtract 1) t - addPending (fromJust $ getPending v) act + waitFor (filter (isWaiting . snd) $ zip ks vs) $ \finish k -> do + s <- readIORef status + let done x = do signalBarrier wait x; return True + case Map.lookup k s of + Just (Error e) -> done $ Left e + Just Ready{} | finish -> done $ Right [value r | k <- ks, let Ready r = fromJust $ Map.lookup k s] + | otherwise -> return False return $ do (dur,res) <- duration $ blockPool pool $ waitBarrier wait return $ case res of @@ -201,36 +202,27 @@ logger $ maybe "Missing" shw (Map.lookup k s) ++ " -> " ++ shw v ++ ", " ++ show k return v - isErrorDirty Error{} = True - isErrorDirty Dirty{} = True - isErrorDirty _ = False - - isCheckingBuilding Checking{} = True - isCheckingBuilding Building{} = True - isCheckingBuilding _ = False - - isReady Ready{} = True - isReady _ = False - atom x = let s = show x in if ' ' `elem` s then "(" ++ s ++ ")" else s -- Rules for each eval* function -- * Must NOT lock -- * Must have an equal return to what is stored in the db at that point - -- * Must return only one of the items in its suffix - - - evalRECB :: [Key] -> Key -> IO Status - evalRECB stack k = do - res <- evalREDCB stack k - case res of - Dirty r -> evalB stack k r - res -> return res + -- * Must not return Loaded + reduce :: [Key] -> Key -> IO Status + reduce stack k = do + s <- readIORef status + case Map.lookup k s of + Nothing -> run stack k Nothing + Just (Loaded r) -> do + b <- valid k (value r) + logger $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (value r) + if not b then run stack k $ Just r else check stack k r (depends r) + Just res -> return res - evalB :: [Key] -> Key -> Maybe Result -> IO Status - evalB stack k r = do - pend <- newIORef (return ()) + run :: [Key] -> Key -> Maybe Result -> IO Waiting + run stack k r = do + w <- newWaiting r addPool pool $ do res <- exec stack k ans <- withLock lock $ do @@ -240,70 +232,45 @@ let c | Just r <- r, value r == v = changed r | otherwise = step in Ready Result{value=v,changed=c,built=step,..} - join $ readIORef pend + runWaiting w return ans case ans of Ready r -> do logger $ "result " ++ atom k ++ " = " ++ atom (value r) appendJournal journal k r -- leave the DB lock before appending _ -> return () - k #= Building (Pending pend) r - - - evalREDCB :: [Key] -> Key -> IO Status - evalREDCB stack k = do - s <- readIORef status - case Map.lookup k s of - Nothing -> evalB stack k Nothing - Just (Loaded r) -> do - b <- valid k (value r) - logger $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (value r) - if not b then evalB stack k $ Just r else checkREDCB stack k r (depends r) - Just res -> return res - + k #= w - checkREDCB :: [Key] -> Key -> Result -> [[Key]] -> IO Status - checkREDCB stack k r [] = + check :: [Key] -> Key -> Result -> [[Key]] -> IO Status + check stack k r [] = k #= Ready r - checkREDCB stack k r (ds:rest) = do - vs <- mapM (evalREDCB (k:stack)) ds - let cb = filter (isCheckingBuilding . snd) $ zip ds vs - if any isErrorDirty vs then - k #= Dirty (Just r) - else if any (> built r) [changed | Ready Result{..} <- vs] then - evalB stack k $ Just r - else if null cb then - checkREDCB stack k r rest + check stack k r (ds:rest) = do + vs <- mapM (reduce (k:stack)) ds + let ws = filter (isWaiting . snd) $ zip ds vs + if any isError vs || any (> built r) [changed | Ready Result{..} <- vs] then + run stack k $ Just r + else if null ws then + check stack k r rest else do - todo <- newIORef $ Just $ length cb -- how many to do - pend <- newIORef $ return () - forM_ cb $ \(d,i) -> - addPending (fromJust $ getPending i) $ do - t <- readIORef todo - when (isJust t) $ do - s <- readIORef status - case Map.lookup d s of - Just v | isErrorDirty v -> do - writeIORef todo Nothing - k #= Dirty (Just r) - join $ readIORef pend - Just (Ready r2) - | changed r2 > built r -> do - writeIORef todo Nothing - Building p _ <- evalB stack k $ Just r - addPending p $ join $ readIORef pend - | fromJust t == 1 -> do - writeIORef todo Nothing - res <- checkREDCB stack k r rest - case getPending res of - Nothing -> join $ readIORef pend - Just p -> addPending p $ join $ readIORef pend - | otherwise -> - writeIORef todo $ fmap (subtract 1) t - Just (Building p _) -> do - writeIORef todo Nothing - addPending p $ join $ readIORef pend - k #= Checking (Pending pend) r + self <- newWaiting $ Just r + waitFor ws $ \finish d -> do + s <- readIORef status + let buildIt = do + b <- run stack k $ Just r + afterWaiting b $ runWaiting self + return True + case Map.lookup d s of + Just Error{} -> buildIt + Just (Ready r2) + | changed r2 > built r -> buildIt + | finish -> do + res <- check stack k r rest + if not $ isWaiting res + then runWaiting self + else afterWaiting res $ runWaiting self + return True + | otherwise -> return False + k #= self --------------------------------------------------------------------- @@ -342,6 +309,25 @@ f _ = [] return $ "[" ++ intercalate "\n," (concatMap f $ Map.toList status) ++ "\n]" + +checkValid :: Database -> (Key -> Value -> IO Bool) -> IO () +checkValid Database{..} valid = do + status <- readIORef status + logger "Starting validity/lint checking" + bad <- fmap concat $ forM (Map.toList status) $ \(k,v) -> case v of + Ready r -> do + good <- valid k (value r) + logger $ "Checking if " ++ show k ++ " is " ++ show (value r) ++ ", " ++ if good then "passed" else "FAILED" + return [show k ++ " is no longer " ++ show (value r) | not good && not (special k)] + _ -> return [] + if null bad + then logger "Validity/lint check passed" + else error $ unlines $ "Error: Dependencies have changed since being built:" : bad + + where + -- special case for these things, since the purpose is to break the invariant + special k = s == "AlwaysRun" || "Oracle " `isPrefixOf` s + where s = show k --------------------------------------------------------------------- -- DATABASE diff --git a/Development/Shake/File.hs b/Development/Shake/File.hs --- a/Development/Shake/File.hs +++ b/Development/Shake/File.hs @@ -94,18 +94,22 @@ -- | Require that the following files are built before continuing. Particularly -- necessary when calling 'system''. As an example: -- --- > "//*.rot13" *> \out -> do --- > let src = dropExtension out --- > need [src] --- > system' ["rot13",src,"-o",out] +-- @ +-- \"//*.rot13\" '*>' \out -> do +-- let src = dropExtension out +-- 'need' [src] +-- 'system'' [\"rot13\",src,\"-o\",out] +-- @ need :: [FilePath] -> Action () need xs = (apply $ map File xs :: Action [FileTime]) >> return () -- | Require that the following are built by the rules, used to specify the target. -- --- > main = shake shakeOptions $ do --- > want ["Main.exe"] --- > ... +-- @ +-- main = 'shake' 'shakeOptions' $ do +-- 'want' [\"Main.exe\"] +-- ... +-- @ -- -- This program will build @Main.exe@, given sufficient rules. want :: [FilePath] -> Rules () @@ -116,9 +120,11 @@ -- the second argument will be used to build it. Usually '*>' is sufficient, but '?>' gives -- additional power. For any file used by the build system, only one rule should return 'True'. -- --- > (all isUpper . takeBaseName) *> \out -> do --- > let src = replaceBaseName out $ map toLower $ takeBaseName out --- > writeFile' . map toUpper =<< readFile' src +-- @ +-- (all isUpper . takeBaseName) '*>' \out -> do +-- let src = replaceBaseName out $ map toLower $ takeBaseName out +-- 'writeFile'' . map toUpper =<< 'readFile'' src +-- @ (?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules () (?>) test act = rule $ \(File x) -> if not $ test x then Nothing else Just $ do @@ -134,10 +140,12 @@ -- | Define a rule that matches a 'FilePattern'. No file required by the system must be -- matched by more than one pattern. For the pattern rules, see '?=='. -- --- > "*.asm.o" *> \out -> do --- > let src = dropExtension out --- > need [src] --- > system' ["as",src,"-o",out] +-- @ +-- \"*.asm.o\" '*>' \out -> do +-- let src = dropExtension out +-- 'need' [src] +-- 'system'' [\"as\",src,\"-o\",out] +-- @ -- -- To define a build system for multiple compiled languages, we recommend using @.asm.o@, -- @.cpp.o@, @.hs.o@, to indicate which language produces an object file. diff --git a/Development/Shake/Rerun.hs b/Development/Shake/Rerun.hs --- a/Development/Shake/Rerun.hs +++ b/Development/Shake/Rerun.hs @@ -13,10 +13,12 @@ newtype AlwaysRerun = AlwaysRerun () - deriving (Show,Typeable,Eq,Hashable,Binary,NFData) + deriving (Typeable,Eq,Hashable,Binary,NFData) +instance Show AlwaysRerun where show _ = "AlwaysRerun" newtype Dirty = Dirty () - deriving (Show,Typeable,Hashable,Binary,NFData) + deriving (Typeable,Hashable,Binary,NFData) +instance Show Dirty where show _ = "Dirty" instance Eq Dirty where a == b = False instance Rule AlwaysRerun Dirty where @@ -26,10 +28,12 @@ -- | Always rerun the associated action. Useful for defining rules that query -- the environment. For example: -- --- > "ghcVersion.txt" *> \out -> do --- > alwaysRerun --- > (stdout,_) <- systemOutput' "ghc" ["--version"] --- > writeFile' out stdout +-- @ +-- \"ghcVersion.txt\" '*>' \out -> do +-- 'alwaysRerun' +-- (stdout,_) <- 'systemOutput' \"ghc\" [\"--version\"] +-- 'writeFileChanged' out stdout +-- @ alwaysRerun :: Action () alwaysRerun = do Dirty _ <- apply1 $ AlwaysRerun (); return () diff --git a/Examples/C/Main.hs b/Examples/C/Main.hs --- a/Examples/C/Main.hs +++ b/Examples/C/Main.hs @@ -11,12 +11,12 @@ obj "Main.exe" *> \out -> do cs <- getDirectoryFiles src "*.c" - let os = map (obj . flip replaceExtension "o") cs + let os = map (obj . (<.> "o")) cs need os system' "gcc" $ ["-o",out] ++ os - obj "*.o" *> \out -> do - let c = src takeBaseName out <.> "c" + obj "*.c.o" *> \out -> do + let c = src takeBaseName out need [c] headers <- cIncludes c need $ map (() src . takeFileName) headers diff --git a/Examples/Util.hs b/Examples/Util.hs --- a/Examples/Util.hs +++ b/Examples/Util.hs @@ -68,6 +68,7 @@ ,"loud" * \o -> o{shakeVerbosity=Loud} ,"diagnostic" * \o -> o{shakeVerbosity=Diagnostic} ,"staunch" * \o -> o{shakeStaunch=True} + ,"lint" * \o -> o{shakeLint=True} ] diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake -version: 0.2.1 +version: 0.2.2 license: BSD3 license-file: LICENSE category: Development @@ -10,10 +10,6 @@ copyright: Neil Mitchell 2011 synopsis: Build system library, like Make, but properly supports generated files. description: - /WARNING/: Shake has only been lightly tested, and there will be bugs (please report them). - The interface is likely to change, although hopefully not significantly. It would be unwise - to build a critical production system on top of the current version of Shake. - . Shake is a Haskell library for writing build systems - designed as a replacement for make. To use Shake the user writes a Haskell program that imports the Shake library, defines some build rules, and calls @@ -62,7 +58,7 @@ bytestring, time, transformers == 0.2.*, - deepseq >= 1.1 && < 1.3 + deepseq >= 1.1 && < 1.4 exposed-modules: Development.Shake