shake 0.2.1 → 0.2.2
raw patch · 7 files changed
+156/−155 lines, 7 filesdep ~deepseq
Dependency ranges changed: deepseq
Files
- Development/Shake/Core.hs +9/−3
- Development/Shake/Database.hs +109/−123
- Development/Shake/File.hs +22/−14
- Development/Shake/Rerun.hs +10/−6
- Examples/C/Main.hs +3/−3
- Examples/Util.hs +1/−0
- shake.cabal +2/−6
Development/Shake/Core.hs view
@@ -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
Development/Shake/Database.hs view
@@ -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
Development/Shake/File.hs view
@@ -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.
Development/Shake/Rerun.hs view
@@ -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 ()
Examples/C/Main.hs view
@@ -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
Examples/Util.hs view
@@ -68,6 +68,7 @@ ,"loud" * \o -> o{shakeVerbosity=Loud} ,"diagnostic" * \o -> o{shakeVerbosity=Diagnostic} ,"staunch" * \o -> o{shakeStaunch=True}+ ,"lint" * \o -> o{shakeLint=True} ]
shake.cabal view
@@ -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