shake 0.6 → 0.7
raw patch · 31 files changed
+867/−361 lines, 31 files
Files
- Development/Shake.hs +10/−4
- Development/Shake/Core.hs +133/−113
- Development/Shake/Database.hs +59/−42
- Development/Shake/Derived.hs +13/−7
- Development/Shake/Directory.hs +45/−15
- Development/Shake/Errors.hs +121/−0
- Development/Shake/File.hs +9/−12
- Development/Shake/FilePattern.hs +51/−1
- Development/Shake/FileTime.hs +0/−1
- Development/Shake/Files.hs +12/−17
- Development/Shake/Oracle.hs +4/−4
- Development/Shake/Progress.hs +129/−0
- Development/Shake/Storage.hs +18/−18
- Development/Shake/Types.hs +42/−63
- Development/Shake/Value.hs +5/−6
- Examples/C/Main.hs +1/−1
- Examples/Self/Main.hs +2/−2
- Examples/Tar/Main.hs +0/−1
- Examples/Test/Assume.hs +4/−8
- Examples/Test/Basic.hs +3/−6
- Examples/Test/Directory.hs +8/−5
- Examples/Test/Errors.hs +1/−1
- Examples/Test/FilePattern.hs +9/−0
- Examples/Test/Files.hs +1/−2
- Examples/Test/Journal.hs +1/−2
- Examples/Test/Oracle.hs +78/−0
- Examples/Test/Progress.hs +61/−0
- Examples/Test/Resources.hs +2/−2
- Examples/Util.hs +13/−19
- Main.hs +27/−8
- shake.cabal +5/−1
Development/Shake.hs view
@@ -64,16 +64,21 @@ -- -- /Acknowledgements/: Thanks to Austin Seipp for properly integrating the profiling code. module Development.Shake(+ -- * Core shake,- -- * Core of Shake- ShakeOptions(..), shakeOptions, Assume(..), Progress(..),+ shakeOptions, #if __GLASGOW_HASKELL__ >= 704 ShakeValue, #endif Rule(..), Rules, defaultRule, rule, action, withoutActions, Action, apply, apply1, traced,- Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, liftIO,+ -- * Configuration+ ShakeOptions(..), Assume(..),+ -- ** Progress reporting+ Progress(..), progressSimple, progressDisplay, progressTitlebar,+ -- ** Verbosity+ Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, quietly, -- * Utility functions module Development.Shake.Derived, -- * File rules@@ -81,7 +86,7 @@ module Development.Shake.Files, FilePattern, (?==), -- * Directory rules- doesFileExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,+ doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs, -- * Additional rules addOracle, askOracle, askOracleWith, alwaysRerun,@@ -96,6 +101,7 @@ import Development.Shake.Types import Development.Shake.Core import Development.Shake.Derived+import Development.Shake.Progress import Development.Shake.Directory import Development.Shake.File
Development/Shake/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE CPP #-}@@ -13,14 +13,17 @@ #endif Rule(..), Rules, defaultRule, rule, action, withoutActions, Action, apply, apply1, traced,- getVerbosity, putLoud, putNormal, putQuiet,+ getVerbosity, putLoud, putNormal, putQuiet, quietly, Resource, newResource, withResource ) where import Control.Exception as E+import Control.Applicative+import Control.Concurrent import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Trans.State as State+import Control.Monad.Trans.Writer.Strict+import Control.Monad.Trans.State.Strict as State import Data.Typeable import Data.Function import Data.List@@ -36,6 +39,7 @@ import Development.Shake.Value import Development.Shake.Report import Development.Shake.Types+import Development.Shake.Errors ---------------------------------------------------------------------@@ -107,34 +111,42 @@ data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value)) ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key-ruleKey = undefined+ruleKey = err "ruleKey" ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value-ruleValue = undefined+ruleValue = err "ruleValue" -- | Define a set of rules. Rules can be created with calls to 'rule', 'defaultRule' or 'action'. Rules are combined -- with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation.-data Rules a = Rules- {value :: a -- not really used, other than for the Monad instance- ,actions :: [Action ()]+newtype Rules a = Rules (Writer SRules a)+ deriving (Monad, Functor, Applicative)++newRules :: SRules -> Rules ()+newRules = Rules . tell++modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()+modifyRules f (Rules r) = Rules $ censor f r++getRules :: Rules () -> SRules+getRules (Rules r) = execWriter r+++data SRules = SRules+ {actions :: [Action ()] ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule)]) -- higher fst is higher priority } -instance Monoid a => Monoid (Rules a) where- mempty = return mempty- mappend a b = (a >> b){value = value a `mappend` value b}--instance Monad Rules where- return x = Rules x [] (Map.fromList [])- Rules v1 x1 x2 >>= f = case f v1 of- Rules v2 y1 y2 -> Rules v2 (x1++y1) (Map.unionWith g x2 y2)- where g (k, v1, xs) (_, v2, ys)+instance Monoid SRules where+ mempty = SRules [] (Map.fromList [])+ mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2)+ where f (k, v1, xs) (_, v2, ys) | v1 == v2 = (k, v1, xs ++ ys)- | otherwise = error $ "There are two incompatible rules for " ++ show k ++ ", producing " ++ show v1 ++ " and " ++ show v2+ | otherwise = errorIncompatibleRules k v1 v2 -instance Functor Rules where- fmap f x = return . f =<< x+instance Monoid a => Monoid (Rules a) where+ mempty = return mempty+ mappend a b = do a <- a; b <- b; return $ mappend a b -- | Like 'rule', but lower priority, if no 'rule' exists then 'defaultRule' is checked.@@ -153,60 +165,66 @@ -- The function 'defaultRule' is priority 0 and 'rule' is priority 1. All rules of the same -- priority must be disjoint. rulePriority :: Rule key value => Int -> (key -> Maybe (Action value)) -> Rules ()-rulePriority i r = mempty{rules = Map.singleton k (k, v, [(i,ARule r)])}+rulePriority i r = newRules mempty{rules = Map.singleton k (k, v, [(i,ARule r)])} where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r -- | Run an action, usually used for specifying top-level requirements. action :: Action a -> Rules ()-action a = mempty{actions=[a >> return ()]}+action a = newRules mempty{actions=[a >> return ()]} -- | Remove all actions specified in a set of rules, usually used for implementing -- command line specification of what to build. withoutActions :: Rules () -> Rules ()-withoutActions x = x{actions=[]}+withoutActions = modifyRules $ \x -> x{actions=[]} --------------------------------------------------------------------- -- MAKE -data S = S+data RuleInfo = RuleInfo+ {stored :: Key -> IO (Maybe Value)+ ,execute :: Key -> Action Value+ ,resultType :: TypeRep+ }++data SAction = SAction -- global constants {database :: Database ,pool :: Pool- ,started :: IO Time- ,stored :: Key -> Value -> IO Bool- ,execute :: Key -> Action Value+ ,timestamp :: IO Time+ ,ruleinfo :: Map.HashMap TypeRep RuleInfo ,output :: String -> IO () ,verbosity :: Verbosity ,logger :: String -> IO ()- ,assume :: Maybe Assume -- stack variables ,stack :: Stack -- local variables ,depends :: [Depends] -- built up in reverse- ,discount :: Duration- ,traces :: [(String, Time, Time)] -- in reverse+ ,discount :: !Duration+ ,traces :: [Trace] -- in reverse } -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'need' to execute files. -- Action values are used by 'rule' and 'action'.-newtype Action a = Action (StateT S IO a)- deriving (Functor, Monad, MonadIO)+newtype Action a = Action (StateT SAction IO a)+ deriving (Monad, MonadIO, Functor, Applicative) -- | Internal main function (not exported publicly) run :: ShakeOptions -> Rules () -> IO () run opts@ShakeOptions{..} rs = do start <- startTime+ rs <- return $ getRules rs registerWitnesses rs - output <- do+ outputLocked <- do lock <- newLock return $ withLock lock . putStrLn - let logger = if shakeVerbosity >= Diagnostic then output . ("% "++) else const $ return ()+ let logger = if shakeVerbosity >= Diagnostic then outputLocked . ("% "++) else const $ return ()+ let output = outputLocked . abbreviate shakeAbbreviations except <- newVar (Nothing :: Maybe SomeException) let staunch act | not shakeStaunch = act >> return ()@@ -219,17 +237,16 @@ when (shakeVerbosity >= Quiet) $ output msg Right _ -> return () - let stored = createStored shakeAssume rs- let execute = createExecute shakeAssume rs+ let ruleinfo = createRuleinfo shakeAssume rs running <- newIORef True flip finally (writeIORef running False) $ do- withDatabase logger shakeFiles shakeVersion shakeFlush $ \database -> do- shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}+ withDatabase opts logger $ \database -> do+ forkIO $ shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running} runPool shakeDeterministic shakeThreads $ \pool -> do- let s0 = S database pool start stored execute output shakeVerbosity logger shakeAssume emptyStack [] 0 []+ let s0 = SAction database pool start ruleinfo output shakeVerbosity logger emptyStack [] 0 [] mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs) when shakeLint $ do- checkValid database stored+ checkValid database (runStored ruleinfo) when (shakeVerbosity >= Loud) $ output "Lint checking succeeded" when (isJust shakeReport) $ do let file = fromJust shakeReport@@ -240,6 +257,18 @@ maybe (return ()) throwIO =<< readVar except +abbreviate :: [(String,String)] -> String -> String+abbreviate [] = id+abbreviate abbrev = f+ where+ -- order so longer appreviations are preferred+ ordAbbrev = reverse $ sortBy (compare `on` length . fst) abbrev++ f [] = []+ f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest+ f (x:xs) = x : f xs++ wrapStack :: IO [String] -> IO a -> IO a wrapStack stk act = E.catch act $ \(SomeException e) -> case cast e of Just s@ShakeException{} -> throw s@@ -248,102 +277,77 @@ throw $ ShakeException stk $ SomeException e -registerWitnesses :: Rules () -> IO ()-registerWitnesses Rules{..} =+registerWitnesses :: SRules -> IO ()+registerWitnesses SRules{..} = forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do registerWitness $ ruleKey r registerWitness $ ruleValue r -createStored :: Maybe Assume -> Rules () -> (Key -> Value -> IO Bool)-createStored assume Rules{..} = \k v ->- let (tk,tv) = (typeKey k, typeValue v) in- case Map.lookup tk mp of- Nothing -> error $- "Error: couldn't find instance Rule " ++ showTypeRepBracket tk ++ " " ++ showTypeRepBracket tv ++- ", perhaps you are missing a call to " ++- (if isOracleTypes tk tv then "addOracle" else "defaultRule/rule") ++ "?"- Just (tv2,_) | tv2 /= tv -> error $- "Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++- ", but did find an instance Rule " ++ show tk ++ " " ++ show tv2 ++- ", perhaps you have the types wrong in your call to apply?"- Just (_, r) -> r k v+createRuleinfo :: Maybe Assume -> SRules -> Map.HashMap TypeRep RuleInfo+createRuleinfo assume SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv where- mp = flip Map.map rules $ \(_,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx))-- -- NOTE: We change the storedValue type so that we always pass in both key and value, rather than having- -- value as a return param. That allows us to give better error messages (see createStored)- ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> IO Bool)- ruleStored _ = if assume == Just AssumeDirty- then \k v -> return False- else \k v -> fmap (== Just v) $ storedValue k---isOracleTypes :: TypeRep -> TypeRep -> Bool-isOracleTypes tk tv = f tk "OracleQ" && f tv "OracleA"- where f t s = show (fst $ splitTyConApp t) == s--showTypeRepBracket :: TypeRep -> String-showTypeRepBracket ty = ['(' | not safe] ++ show ty ++ [')' | not safe]- where (t1,args) = splitTyConApp ty- st1 = show t1- safe = null args || st1 == "[]" || "(" `isPrefixOf` st1-+ stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey+ where f :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value))+ f _ = storedValue -createExecute :: Maybe Assume -> Rules () -> (Key -> Action Value)-createExecute assume Rules{..} = \k ->- let tk = typeKey k- norm = case Map.lookup tk mp of- Nothing -> error $- "Error: couldn't find any rules to build " ++ show k ++ " of type " ++ show tk ++- ", perhaps you are missing a call to defaultRule/rule?"- Just rs -> case filter (not . null) $ map (mapMaybe ($ k)) rs of+ execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of [r]:_ -> r- rs ->- let s = if null rs then "no" else show (length $ head rs)- in error $ "Error: " ++ s ++ " rules match for Rule " ++ show k ++ " of type " ++ show tk- clean = case Map.lookup tk mpClean of- Nothing -> norm -- should reraise an error- Just stored -> do res <- liftIO $ stored k; maybe norm return res- in if assume == Just AssumeClean then clean else norm- where- mp = flip Map.map rules $ \(_,_,rs) -> sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs]+ rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)+ where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst) - mpClean = flip Map.map rules $ \(_,_,(_,ARule r):_) -> \k -> fmap (fmap newValue) $ ruleStored r $ fromKey k+runStored :: Map.HashMap TypeRep RuleInfo -> Key -> IO (Maybe Value)+runStored mp k = case Map.lookup (typeKey k) mp of+ Nothing -> return Nothing+ Just RuleInfo{..} -> stored k - ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value))- ruleStored _ = storedValue+runExecute :: Map.HashMap TypeRep RuleInfo -> Key -> Action Value+runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of+ Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing -- Not sure if this is even possible, but best be safe+ Just RuleInfo{..} -> execute k -runAction :: S -> Action a -> IO (a, S)+runAction :: SAction -> Action a -> IO (a, SAction) runAction s (Action x) = runStateT x s -- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel. -- This function requires that appropriate rules have been added with 'rule' or 'defaultRule'. apply :: Rule key value => [key] -> Action [value]-apply ks = fmap (map fromValue) $ applyKeyValue $ map newKey ks+apply = f+ where+ -- We don't want the forall in the Haddock docs+ f :: forall key value . Rule key value => [key] -> Action [value]+ f ks = do+ ruleinfo <- Action $ State.gets ruleinfo+ let tk = typeOf (err "apply key" :: key)+ tv = typeOf (err "apply type" :: value)+ case Map.lookup tk ruleinfo of+ Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv)+ Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv+ _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks + applyKeyValue :: [Key] -> Action [Value]-applyKeyValue ks = Action $ do- s <- State.get+applyKeyValue ks = do+ s <- Action State.get let exec stack k = try $ wrapStack (showStack (database s) stack) $ do evaluate $ rnf k let s2 = s{depends=[], stack=stack, discount=0, traces=[]} (dur,(res,s2)) <- duration $ runAction s2 $ do- putNormal $ "# " ++ show k- execute s k+ putLoud $ "# " ++ show k+ runExecute (ruleinfo s) k let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2) evaluate $ rnf ans return ans- res <- liftIO $ build (pool s) (database s) (Ops (stored s) exec) (assume s) (stack s) ks+ res <- liftIO $ build (pool s) (database s) (Ops (runStored (ruleinfo s)) exec) (stack s) ks case res of Left err -> throw err Right (dur, dep, vs) -> do- State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s}+ Action $ State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s} return vs @@ -357,18 +361,19 @@ -- The 'Develoment.Shake.system'' command automatically calls 'traced'. The trace list is used for profile reports -- (see 'shakeReport'). traced :: String -> IO a -> Action a-traced msg act = Action $ do- s <- State.get- start <- liftIO $ started s+traced msg act = do+ s <- Action State.get+ start <- liftIO $ timestamp s+ putNormal $ "# " ++ topStack (stack s) ++ " " ++ msg res <- liftIO act- stop <- liftIO $ started s- State.modify $ \s -> s{traces = (msg,start,stop):traces s}+ stop <- liftIO $ timestamp s+ Action $ State.modify $ \s -> s{traces = (pack msg,start,stop):traces s} return res putWhen :: (Verbosity -> Bool) -> String -> Action ()-putWhen f msg = Action $ do- s <- State.get+putWhen f msg = do+ s <- Action State.get when (f $ verbosity s) $ liftIO $ output s msg @@ -389,11 +394,26 @@ getVerbosity :: Action Verbosity getVerbosity = Action $ gets verbosity +-- | Run an action with a particular verbosity level.+withVerbosity :: Verbosity -> Action a -> Action a+withVerbosity new act = do+ old <- Action $ State.gets verbosity+ Action $ State.modify $ \s -> s{verbosity=new}+ res <- act+ Action $ State.modify $ \s -> s{verbosity=old}+ return res ++-- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'+-- (including from 'Development.Shake.system'') will not be printed to the screen.+quietly :: Action a -> Action a+quietly = withVerbosity Quiet++ -- | Run an action which uses part of a finite resource. For an example see 'Resource'. withResource :: Resource -> Int -> Action a -> Action a-withResource r i act = Action $ do- s <- State.get+withResource r i act = do+ s <- Action State.get (res,s) <- liftIO $ bracket_ (do res <- acquireResource r i case res of@@ -405,5 +425,5 @@ (do releaseResource r i logger s $ show r ++ " released " ++ show i) (runAction s act)- State.put s+ Action $ State.put s return res
Development/Shake/Database.hs view
@@ -7,7 +7,7 @@ Database, withDatabase, Ops(..), build, Depends, progress,- Stack, emptyStack, showStack,+ Stack, emptyStack, showStack, topStack, showJSON, checkValid, ) where @@ -15,6 +15,7 @@ import Development.Shake.Binary import Development.Shake.Pool import Development.Shake.Value+import Development.Shake.Errors import Development.Shake.Locks import Development.Shake.Storage import Development.Shake.Types@@ -27,6 +28,7 @@ import Data.IORef import Data.Maybe import Data.List+import Data.Monoid import Data.Time.Clock type Map = Map.HashMap@@ -68,30 +70,32 @@ --------------------------------------------------------------------- -- CALL STACK -newtype Stack = Stack [Id]+data Stack = Stack (Maybe Key) [Id] showStack :: Database -> Stack -> IO [String]-showStack Database{..} (Stack xs) = do+showStack Database{..} (Stack _ xs) = do status <- withLock lock $ readIORef status return $ reverse $ map (maybe "<unknown>" (show . fst) . flip Map.lookup status) xs -addStack :: Id -> Stack -> Stack-addStack x (Stack xs) = Stack $ x : xs+addStack :: Id -> Key -> Stack -> Stack+addStack x key (Stack _ xs) = Stack (Just key) $ x : xs +topStack :: Stack -> String+topStack (Stack key _) = maybe "<unknown>" show key+ checkStack :: [Id] -> Stack -> Maybe Id-checkStack new (Stack old)+checkStack new (Stack _ old) | bad:_ <- old `intersect` new = Just bad | otherwise = Nothing emptyStack :: Stack-emptyStack = Stack []+emptyStack = Stack Nothing [] --------------------------------------------------------------------- -- CENTRAL TYPES -type Trace = (String, Time, Time)-+type Trace = (BS, Time, Time) -- (message, start, end) -- | Invariant: The database does not have any cycles when a Key depends on itself data Database = Database@@ -101,6 +105,7 @@ ,step :: Step ,journal :: Id -> (Key, Status {- Loaded or Missing -}) -> IO () ,logger :: String -> IO () -- logging function+ ,assume :: Maybe Assume } data Status@@ -109,9 +114,7 @@ | Loaded Result -- Loaded from the database | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building | Missing -- I am only here because I got into the Intern table- deriving Show --- FIXME: Probably want Step's to be strict and unpacked? Benchmark on a large example data Result = Result {result :: Value -- the result associated with the Key ,built :: {-# UNPACK #-} !Step -- when it was actually run@@ -119,7 +122,7 @@ ,depends :: [[Id]] -- dependencies ,execution :: {-# UNPACK #-} !Duration -- how long it took when it was last run (seconds) ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run)- } deriving Show+ } newtype Pending = Pending (IORef (IO ()))@@ -129,6 +132,12 @@ instance Show Pending where show _ = "Pending" +statusType Ready{} = "Ready"+statusType Error{} = "Error"+statusType Loaded{} = "Loaded"+statusType Waiting{} = "Waiting"+statusType Missing{} = "Missing"+ isError Error{} = True; isError _ = False isWaiting Waiting{} = True; isWaiting _ = False isReady Ready{} = True; isReady _ = False@@ -173,16 +182,16 @@ deriving (NFData) data Ops = Ops- {valid :: Key -> Value -> IO Bool+ {stored :: Key -> IO (Maybe Value) -- ^ Given a Key and a Value from the database, check it still matches the value stored on disk- ,exec :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace]))+ ,execute :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace])) -- ^ Given a chunk of stack (bottom element first), and a key, either raise an exception or successfully build it } -- | Return either an exception (crash), or (how much time you spent waiting, the value)-build :: Pool -> Database -> Ops -> Maybe Assume -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value]))-build pool Database{..} Ops{..} assume stack ks = do+build :: Pool -> Database -> Ops -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value]))+build pool Database{..} Ops{..} stack ks = do join $ withLock lock $ do is <- forM ks $ \k -> do is <- readIORef intern@@ -196,7 +205,9 @@ whenJust (checkStack is stack) $ \bad -> do status <- readIORef status- error $ "Invalid rules, recursion detected when trying to build: " ++ maybe "<unknown>" (show . fst) (Map.lookup bad status)+ uncurry errorRuleRecursion $ case Map.lookup bad status of+ Nothing -> (Nothing, Nothing)+ Just (k,_) -> (Just $ typeKey k, Just $ show k) vs <- mapM (reduce stack) is let errs = [e | Error e <- vs]@@ -223,8 +234,7 @@ i #= (k,v) = do s <- readIORef status writeIORef status $ Map.insert i (k,v) s- let shw = head . words . show- logger $ maybe "Missing" (shw . snd) (Map.lookup i s) ++ " -> " ++ shw v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s)+ logger $ maybe "Missing" (statusType . snd) (Map.lookup i s) ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s) return v atom x = let s = show x in if ' ' `elem` s then "(" ++ s ++ ")" else s@@ -238,10 +248,10 @@ reduce stack i = do s <- readIORef status case Map.lookup i s of- Nothing -> error $ "Shake internal error: interned value " ++ show i ++ " is missing from the database"+ Nothing -> err $ "interned value missing from database, " ++ show i Just (k, Missing) -> run stack i k Nothing Just (k, Loaded r) -> do- b <- valid k $ result r+ b <- if assume == Just AssumeDirty then return False else fmap (== Just (result r)) $ stored k logger $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (result r) if not b then run stack i k $ Just r else check stack i k r (depends r) Just (k, res) -> return res@@ -250,16 +260,24 @@ run stack i k r = do w <- newWaiting r addPool pool $ do- res <- exec (addStack i stack) k+ let norm = do+ res <- execute (addStack i k stack) k+ return $ case res of+ Left err -> Error err+ Right (v,deps,execution,traces) ->+ let c | Just r <- r, result r == v = changed r+ | otherwise = step+ in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..}+ res <- case r of+ Just r | assume == Just AssumeClean -> do+ v <- stored k+ case v of+ Just v -> return $ Ready r{result=v}+ Nothing -> norm+ _ -> norm+ ans <- withLock lock $ do- ans <- i #= (k, case res of- Left err -> Error err- Right (v,deps,execution,traces) ->- case assume of- Just AssumeClean | Just r <- r -> Ready r{result=v}- _ -> let c | Just r <- r, result r == v = changed r- | otherwise = step- in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..})+ ans <- i #= (k, res) runWaiting w return ans case ans of@@ -276,7 +294,7 @@ check stack i k r [] = i #= (k, Ready r) check stack i k r (ds:rest) = do- vs <- mapM (reduce (addStack i stack)) ds+ vs <- mapM (reduce (addStack i 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 i k $ Just r@@ -311,8 +329,7 @@ progress :: Database -> IO Progress progress Database{..} = do s <- readIORef status- let zero = Progress False 0 0 0 0 0 0 0 (0,0)- return $ foldl' f zero $ map snd $ Map.elems s+ return $ foldl' f mempty $ map snd $ Map.elems s where f s (Ready Result{..}) = if step == built then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + execution}@@ -385,18 +402,18 @@ ,"execution:" ++ show execution] ++ ["traces:[" ++ intercalate "," (map showTrace traces) ++ "]" | traces /= []] showStep i = show $ fromJust $ Map.lookup i steps- showTrace (a,b,c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show a ++ "}"+ showTrace (a,b,c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show (unpack a) ++ "}" in ["{" ++ intercalate ", " xs ++ "}"] return $ "[" ++ intercalate "\n," (concat [maybe (error "Internal error in showJSON") f $ Map.lookup i status | i <- order]) ++ "\n]" -checkValid :: Database -> (Key -> Value -> IO Bool) -> IO ()-checkValid Database{..} valid = do+checkValid :: Database -> (Key -> IO (Maybe Value)) -> IO ()+checkValid Database{..} stored = do status <- readIORef status logger "Starting validity/lint checking" bad <- fmap concat $ forM (Map.toList status) $ \(i,v) -> case v of (key, Ready Result{..}) -> do- good <- valid key result+ good <- fmap (== Just result) $ stored key logger $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if good then "passed" else "FAILED" return [show key ++ " is no longer " ++ show result | not good && not (special key)] _ -> return []@@ -427,12 +444,12 @@ fromStepResult = fromValue . result -withDatabase :: (String -> IO ()) -> FilePath -> Int -> Maybe Double -> (Database -> IO a) -> IO a-withDatabase logger filename version flush act = do+withDatabase :: ShakeOptions -> (String -> IO ()) -> (Database -> IO a) -> IO a+withDatabase opts logger act = do registerWitness $ StepKey () registerWitness $ Step 0 witness <- currentWitness- withStorage logger filename version flush witness $ \mp2 journal -> do+ withStorage opts logger witness $ \mp2 journal -> do let mp1 = Intern.fromList [(k, i) | (i, (k,_)) <- Map.toList mp2] (mp1, stepId) <- case Intern.lookup stepKey mp1 of@@ -448,7 +465,7 @@ _ -> Step 1 journal stepId (stepKey, Loaded $ toStepResult step) lock <- newLock- act Database{..}+ act Database{assume=shakeAssume opts,..} instance BinaryWith Witness Step where@@ -462,5 +479,5 @@ instance BinaryWith Witness Status where putWith ctx Missing = putWord8 0 putWith ctx (Loaded x) = putWord8 1 >> putWith ctx x- putWith ctx x = error $ "putWith: Cannot write Status with constructor " ++ head (words $ show x)+ putWith ctx x = err $ "putWith, Cannot write Status with constructor " ++ statusType x getWith ctx = do i <- getWord8; if i == 0 then return Missing else fmap Loaded $ getWith ctx
Development/Shake/Derived.hs view
@@ -1,5 +1,10 @@ -module Development.Shake.Derived where+module Development.Shake.Derived(+ system', systemCwd, systemOutput,+ copyFile',+ readFile', readFileLines,+ writeFile', writeFileLines, writeFileChanged+ ) where import Control.Monad import Control.Monad.IO.Class@@ -13,6 +18,10 @@ import Development.Shake.FilePath +checkExitCode :: String -> ExitCode -> Action ()+checkExitCode cmd ExitSuccess = return ()+checkExitCode cmd (ExitFailure i) = error $ "System command failed (code " ++ show i ++ "):\n" ++ cmd+ -- | Execute a system command. This function will raise an error if the exit code is non-zero. -- Before running 'system'' make sure you 'need' any required files. system' :: FilePath -> [String] -> Action ()@@ -21,8 +30,7 @@ let cmd = unwords $ path2 : args putLoud cmd res <- traced (takeBaseName path) $ rawSystem path2 args- when (res /= ExitSuccess) $- error $ "System command failed:\n" ++ cmd+ checkExitCode cmd res -- | Execute a system command with a specified current working directory (first argument).@@ -40,8 +48,7 @@ -- That installs/removes signal handlers. hdl <- runProcess path2 args (Just cwd) Nothing Nothing Nothing Nothing waitForProcess hdl- when (res /= ExitSuccess) $- error $ "System command failed:\n" ++ cmd+ checkExitCode cmd res -- | Execute a system command, returning @(stdout,stderr)@.@@ -53,8 +60,7 @@ let cmd = unwords $ path2 : args putLoud cmd (res,stdout,stderr) <- traced (takeBaseName path) $ readProcessWithExitCode path2 args ""- when (res /= ExitSuccess) $- error $ "System command failed:\n" ++ cmd ++ "\n" ++ stderr+ checkExitCode cmd res return (stdout, stderr)
Development/Shake/Directory.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-} module Development.Shake.Directory(- doesFileExist,+ doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs, defaultRuleDirectory ) where@@ -31,9 +31,22 @@ show (DoesFileExistA a) = show a +newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesDirectoryExistQ where+ show (DoesDirectoryExistQ a) = "Exists dir? " ++ a++newtype DoesDirectoryExistA = DoesDirectoryExistA Bool+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesDirectoryExistA where+ show (DoesDirectoryExistA a) = show a++ data GetDirectoryQ = GetDir {dir :: FilePath}- | GetDirFiles {dir :: FilePath, pat :: FilePattern}+ | GetDirFiles {dir :: FilePath, pat :: [FilePattern]} | GetDirDirs {dir :: FilePath} deriving (Typeable,Eq) newtype GetDirectoryA = GetDirectoryA [FilePath]@@ -41,7 +54,8 @@ instance Show GetDirectoryQ where show (GetDir x) = "Listing " ++ x- show (GetDirFiles a b) = "Files " ++ a </> b+ show (GetDirFiles a b) = "Files " ++ a </> ['{'|m] ++ unwords b ++ ['}'|m]+ where m = length b > 1 show (GetDirDirs x) = "Dirs " ++ x instance NFData GetDirectoryQ where@@ -51,9 +65,9 @@ instance Hashable GetDirectoryQ where hashWithSalt salt = hashWithSalt salt . f- where f (GetDir x) = (0 :: Int, x, "")+ where f (GetDir x) = (0 :: Int, x, []) f (GetDirFiles x y) = (1, x, y)- f (GetDirDirs x) = (2, x, "")+ f (GetDirDirs x) = (2, x, []) instance Binary GetDirectoryQ where get = do@@ -72,6 +86,10 @@ storedValue (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x -- invariant _ = True +instance Rule DoesDirectoryExistQ DoesDirectoryExistA where+ storedValue (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x+ -- invariant _ = True+ instance Rule GetDirectoryQ GetDirectoryA where storedValue x = fmap Just $ getDir x -- invariant _ = True@@ -82,6 +100,8 @@ defaultRuleDirectory = do defaultRule $ \(DoesFileExistQ x) -> Just $ liftIO $ fmap DoesFileExistA $ IO.doesFileExist x+ defaultRule $ \(DoesDirectoryExistQ x) -> Just $+ liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x defaultRule $ \(x :: GetDirectoryQ) -> Just $ liftIO $ getDir x @@ -92,6 +112,12 @@ DoesFileExistA res <- apply1 $ DoesFileExistQ file return res +-- | Returns 'True' if the directory exists.+doesDirectoryExist :: FilePath -> Action Bool+doesDirectoryExist file = do+ DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ file+ return res+ -- | Get the contents of a directory. The result will be sorted, and will not contain -- the files @.@ or @..@ (unlike the standard Haskell version). It is usually better to -- call either 'getDirectoryFiles' or 'getDirectoryDirs'. The resulting paths will be relative@@ -99,9 +125,9 @@ getDirectoryContents :: FilePath -> Action [FilePath] getDirectoryContents x = getDirAction $ GetDir x --- | Get the files in a directory that match a particular pattern.+-- | Get the files in a directory that match any of a set of patterns. -- For the interpretation of the pattern see '?=='.-getDirectoryFiles :: FilePath -> FilePattern -> Action [FilePath]+getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath] getDirectoryFiles x f = getDirAction $ GetDirFiles x f -- | Get the directories contained by a directory, does not include @.@ or @..@.@@ -110,13 +136,17 @@ getDirAction x = do GetDirectoryA y <- apply1 x; return y +contents :: FilePath -> IO [FilePath]+contents = fmap (filter $ not . all (== '.')) . IO.getDirectoryContents +answer :: [FilePath] -> GetDirectoryA+answer = GetDirectoryA . sort+ getDir :: GetDirectoryQ -> IO GetDirectoryA-getDir x = fmap (GetDirectoryA . sort) $ f x . filter validName =<< IO.getDirectoryContents (dir x)- where- validName = not . all (== '.')+getDir GetDir{..} = fmap answer $ contents dir - f GetDir{} xs = return xs- f GetDirFiles{} xs = flip filterM xs $ \s ->- if not $ pat x ?== s then return False else IO.doesFileExist $ dir x </> s- f GetDirDirs{} xs = flip filterM xs $ \s -> IO.doesDirectoryExist $ dir x </> s+getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir+ where f x = IO.doesDirectoryExist $ dir </> x++getDir GetDirFiles{..} = fmap answer $ filterM f =<< contents dir+ where f x = if not $ any (?== x) pat then return False else IO.doesFileExist $ dir </> x
+ Development/Shake/Errors.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}++-- | Errors seen by the user+module Development.Shake.Errors(+ ShakeException(..),+ errorNoRuleToBuildType, errorRuleTypeMismatch, errorIncompatibleRules,+ errorMultipleRulesMatch, errorRuleRecursion,+ err+ ) where++import Control.Arrow+import Control.Exception+import Data.Typeable+import Data.List+++err :: String -> a+err msg = error $ "Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")"++alternatives = let (*) = (,) in+ ["_rule_" * "oracle"+ ,"_Rule_" * "Oracle"+ ,"_key_" * "question"+ ,"_Key_" * "Question"+ ,"_result_" * "answer"+ ,"_Result_" * "Answer"+ ,"_rule/defaultRule_" * "addOracle"+ ,"_apply_" * "askOracle"]++structured :: Bool -> String -> [(String, Maybe String)] -> String -> a+structured alt msg args hint = structured_ (f msg) (map (first f) args) (f hint)+ where+ f = filter (/= '_') . (if alt then g else id)+ g xs | (a,b):_ <- filter (\(a,b) -> a `isPrefixOf` xs) alternatives = b ++ g (drop (length a) xs)+ g (x:xs) = x : g xs+ g [] = []++structured_ :: String -> [(String, Maybe String)] -> String -> a+structured_ msg args hint = error $+ msg ++ ":\n" ++ unlines [" " ++ a ++ ":" ++ replicate (as - length a + 2) ' ' ++ drp b | (a,b) <- args2] ++ hint+ where+ drp x | "OracleA " `isPrefixOf` x = drop 8 x+ | "OracleQ " `isPrefixOf` x = drop 8 x+ | otherwise = x+ as = maximum $ 0 : map (length . fst) args2+ args2 = [(a,b) | (a,Just b) <- args]+++errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> a+errorNoRuleToBuildType tk k tv = structured (isOracle tk)+ "Build system error - no _rule_ matches the _key_ type"+ [("_Key_ type", Just $ show tk)+ ,("_Key_ value", k)+ ,("_Result_ type", fmap show tv)]+ "Either you are missing a call to _rule/defaultRule_, or your call to _apply_ has the wrong _key_ type"++errorRuleTypeMismatch :: TypeRep -> Maybe String -> TypeRep -> TypeRep -> a+errorRuleTypeMismatch tk k tvReal tvWant = structured (isOracle tk)+ "Build system error - _rule_ used at the wrong _result_ type"+ [("_Key_ type", Just $ show tk)+ ,("_Key_ value", k)+ ,("_Rule_ _result_ type", Just $ show tvReal)+ ,("Requested _result_ type", Just $ show tvWant)]+ "Either the function passed to _rule/defaultRule_ has the wrong _result_ type, or the result of _apply_ is used at the wrong type"++errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> a+errorIncompatibleRules tk tv1 tv2 = if isOracle tk then errorDuplicateOracle tk Nothing [tv1,tv2] else structured_+ "Build system error - rule has multiple result types"+ [("Key type", Just $ show tk)+ ,("First result type", Just $ show tv1)+ ,("Second result type", Just $ show tv2)]+ "A function passed to rule/defaultRule has the wrong result type"++errorMultipleRulesMatch :: TypeRep -> String -> Int -> a+errorMultipleRulesMatch tk k count+ | isOracle tk = if count == 0 then err $ "no oracle match for " ++ show tk else errorDuplicateOracle tk (Just k) []+ | otherwise = structured_+ ("Build system error - key matches " ++ (if count == 0 then "no" else "multiple") ++ " rules")+ [("Key type",Just $ show tk)+ ,("Key value",Just k)+ ,("Rules matched",Just $ show count)]+ (if count == 0 then "Either add a rule that produces the above key, or stop requiring the above key"+ else "Modify your rules/defaultRules so only one can produce the above key")++errorRuleRecursion :: Maybe TypeRep -> Maybe String -> a+errorRuleRecursion tk k = structured_ -- may involve both rules and oracle, so report as a rule+ "Build system error - recursion detected"+ [("Key type",fmap show tk)+ ,("Key value",k)]+ "Rules may not be recursive"++errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> a+errorDuplicateOracle tk k tvs = structured_+ "Build system error - duplicate oracles for the same question type"+ ([("Question type",Just $ show tk)+ ,("Question value",k)] +++ [("Answer type " ++ show i, Just $ show tv) | (i,tv) <- zip [1..] tvs])+ "Only one call to addOracle is allowed per question type"+++isOracle :: TypeRep -> Bool+isOracle t = con `elem` ["OracleQ","OracleA"]+ where con = show $ fst $ splitTyConApp t+++-- NOTE: Not currently public, to avoid pinning down the API yet+-- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing+-- rules, will be raised using this exception type.+data ShakeException = ShakeException+ [String] -- Entries on the stack, starting at the top of the stack.+ SomeException -- Inner exception that was raised.+ -- If I make these Haddock comments, then Haddock dies+ deriving Typeable++instance Exception ShakeException++instance Show ShakeException where+ show (ShakeException stack inner) = unlines $+ "Error when running Shake build system:" :+ map ("* " ++) stack +++ [show inner]
Development/Shake/File.hs view
@@ -8,9 +8,9 @@ import Control.Monad.IO.Class import System.Directory-import qualified Data.ByteString.Char8 as BS import Development.Shake.Core+import Development.Shake.Types import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.FilePattern@@ -19,19 +19,16 @@ infix 1 *>, ?>, **> -newtype FileQ = FileQ BS.ByteString- deriving (Typeable,Eq,Hashable,Binary)--instance NFData FileQ where- rnf (FileQ x) = x `seq` () -- since ByteString is strict+newtype FileQ = FileQ BS+ deriving (Typeable,Eq,Hashable,Binary,NFData) -instance Show FileQ where show (FileQ x) = BS.unpack x+instance Show FileQ where show (FileQ x) = unpack x newtype FileA = FileA FileTime deriving (Typeable,Eq,Hashable,Binary,Show,NFData) instance Rule FileQ FileA where- storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x+ storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe $ unpack_ x {- observed act = do@@ -91,7 +88,7 @@ -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleFile :: Rules () defaultRuleFile = defaultRule $ \(FileQ x) -> Just $- liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x+ liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" $ unpack_ x -- | Require that the following files are built before continuing. Particularly@@ -104,7 +101,7 @@ -- 'Development.Shake.system'' [\"rot13\",src,\"-o\",out] -- @ need :: [FilePath] -> Action ()-need xs = (apply $ map (FileQ . BS.pack) xs :: Action [FileA]) >> return ()+need xs = (apply $ map (FileQ . pack) xs :: Action [FileA]) >> return () -- | Require that the following are built by the rules, used to specify the target. --@@ -120,11 +117,11 @@ root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-root help test act = rule $ \(FileQ x_) -> let x = BS.unpack x_ in+root help test act = rule $ \(FileQ x_) -> let x = unpack x_ in if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x act x- liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_+ liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") $ unpack_ x_
Development/Shake/FilePattern.hs view
@@ -1,12 +1,19 @@+{-# LANGUAGE PatternGuards #-} module Development.Shake.FilePattern( FilePattern, (?==),- compatible, extract, substitute+ compatible, extract, substitute,+ directories, directories1 ) where import System.FilePath(pathSeparators)+import Data.List+import Control.Arrow +---------------------------------------------------------------------+-- BASIC FILE PATTERN MATCHING+ -- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax -- and semantics of 'FilePattern' see '?=='. type FilePattern = String@@ -15,7 +22,10 @@ data Lexeme = Star | SlashSlash | Char Char deriving (Show, Eq) isChar (Char _) = True; isChar _ = False+isDull (Char x) = x /= '/'; isDull _ = False+fromChar (Char x) = x + data Regex = Lit [Char] | Not [Char] | Any | Start | End | Bracket Regex@@ -89,6 +99,46 @@ (?==) :: FilePattern -> FilePath -> Bool (?==) p x = not $ null $ match (pattern $ lexer p) (True, x) ++---------------------------------------------------------------------+-- DIRECTORY PATTERNS++-- | Given a pattern, return the directory that requires searching,+-- with 'True' if it requires a recursive search. Must be conservative.+-- Examples:+--+-- > directories1 "*.xml" == ("",False)+-- > directories1 "//*.xml" == ("",True)+-- > directories1 "foo//*.xml" == ("foo",True)+-- > directories1 "foo/bar/*.xml" == ("foo/bar",False)+-- > directories1 "*/bar/*.xml" == ("",True)+directories1 :: FilePattern -> (FilePath, Bool)+directories1 = first (intercalate "/") . f . lexer+ where+ f xs | (a@(_:_),b:bs) <- span isDull xs, b `elem` [Char '/',SlashSlash] =+ if b == SlashSlash then ([map fromChar a],True) else first (map fromChar a:) $ f bs+ | all (\x -> isDull x || x == Star) xs = ([],False)+ | otherwise = ([], True)+++-- | Given a set of patterns, produce a set of directories that require searching,+-- with 'True' if it requires a recursive search. Must be conservative. Examples:+--+-- > directories ["*.xml","//*.c"] == [("",True)]+-- > directories ["bar/*.xml","baz//*.c"] == [("bar",False),("baz",True)]+-- > directories ["bar/*.xml","baz//*.c"] == [("bar",False),("baz",True)]+directories :: [FilePattern] -> [(FilePath,Bool)]+directories ps = foldl f xs xs+ where+ xs = nub $ map directories1 ps ++ -- Eliminate anything which is a strict subset+ f xs (x,True) = filter (\y -> not $ (x,False) == y || (x ++ "/") `isPrefixOf` fst y) xs+ f xs _ = xs+++---------------------------------------------------------------------+-- MULTIPATTERN COMPATIBLE SUBSTITUTIONS -- | Do they have the same * and // counts in the same order compatible :: [FilePattern] -> Bool
Development/Shake/FileTime.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Development.Shake.FileTime( FileTime,
Development/Shake/Files.hs view
@@ -7,9 +7,9 @@ import Control.Monad import Control.Monad.IO.Class import Data.Maybe-import qualified Data.ByteString.Char8 as BS import Development.Shake.Core+import Development.Shake.Types import Development.Shake.Classes import Development.Shake.File import Development.Shake.FilePattern@@ -18,22 +18,17 @@ infix 1 ?>>, *>> -newtype FilesQ = FilesQ [BS.ByteString]- deriving (Typeable,Eq,Hashable,Binary)--instance NFData FilesQ where- -- some versions of ByteString do not have NFData instances, but seq is equivalent- -- for a strict bytestring. Therefore, we write our own instance.- rnf (FilesQ xs) = rnf $ map (`seq` ()) xs+newtype FilesQ = FilesQ [BS]+ deriving (Typeable,Eq,Hashable,Binary,NFData) newtype FilesA = FilesA [FileTime] deriving (Typeable,Show,Eq,Hashable,Binary,NFData) -instance Show FilesQ where show (FilesQ xs) = unwords $ map BS.unpack xs+instance Show FilesQ where show (FilesQ xs) = unwords $ map unpack xs instance Rule FilesQ FilesA where- storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs+ storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe $ map unpack_ xs -- | Define a rule for building multiple files at the same time.@@ -57,9 +52,9 @@ | otherwise = do forM_ ps $ \p -> p *> \file -> do- _ :: FilesA <- apply1 $ FilesQ $ map (BS.pack . substitute (extract p file)) ps+ _ :: FilesA <- apply1 $ FilesQ $ map (pack . substitute (extract p file)) ps return ()- rule $ \(FilesQ xs_) -> let xs = map BS.unpack xs_ in+ rule $ \(FilesQ xs_) -> let xs = map unpack xs_ in if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do act xs liftIO $ getFileTimes "*>>" xs_@@ -93,10 +88,10 @@ | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x isJust . checkedTest ?> \x -> do- _ :: FilesA <- apply1 $ FilesQ $ map BS.pack $ fromJust $ test x+ _ :: FilesA <- apply1 $ FilesQ $ map pack $ fromJust $ test x return () - rule $ \(FilesQ xs_) -> let xs@(x:_) = map BS.unpack xs_ in+ rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpack xs_ in case checkedTest x of Just ys | ys == xs -> Just $ do act xs@@ -105,13 +100,13 @@ Nothing -> Nothing -getFileTimes :: String -> [BS.ByteString] -> IO FilesA+getFileTimes :: String -> [BS] -> IO FilesA getFileTimes name xs = do- ys <- mapM getModTimeMaybe xs+ ys <- mapM (getModTimeMaybe . unpack_) xs case sequence ys of Just ys -> return $ FilesA ys Nothing -> do let missing = length $ filter isNothing ys error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++ " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++- concat ["\n " ++ BS.unpack x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]+ concat ["\n " ++ unpack x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
Development/Shake/Oracle.hs view
@@ -61,17 +61,17 @@ --newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData) -- --do--- getPkgList <- 'addOracle' $ \\GhcPkgList{} -> do--- (out,_) <- 'systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"]+-- getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do+-- (out,_) <- 'Development.Shake.systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"] -- return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x] -- ----- getPkgVersion <- 'addOracle' $ \\(GhcPkgVersion pkg) -> do+-- getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do -- pkgs <- getPkgList -- return $ lookup pkg pkgs -- @ -- -- Using these definitions, any rule depending on the version of @shake@--- should call @getPkgVersion "shake"@ to rebuild when @shake@ is upgraded.+-- should call @getPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded. addOracle :: ( #if __GLASGOW_HASKELL__ >= 704 ShakeValue q, ShakeValue a
+ Development/Shake/Progress.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ForeignFunctionInterface #-}++-- | Progress tracking+module Development.Shake.Progress(+ Progress(..),+ progressSimple, progressDisplay, progressTitlebar,+ ) where++import Control.Concurrent+import Data.Data+import Data.Monoid+import qualified Data.ByteString.Char8 as BS++#ifdef mingw32_HOST_OS++import Foreign+import Foreign.C.Types++type LPCSTR = Ptr CChar++foreign import stdcall "Windows.h SetConsoleTitleA" c_setConsoleTitle :: LPCSTR -> IO Bool++#endif+++-- | Information about the current state of the build, obtained by passing a callback function+-- to 'Development.Shake.shakeProgress'. Typically a program will use 'progressDisplay' to poll this value and produce+-- status messages, which is implemented using this data type.+data Progress = Progress+ {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.+ ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.+ ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.+ ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.+ ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.+ ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.+ ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.+ ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.+ ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).+ }+ deriving (Eq,Ord,Show,Data,Typeable)++instance Monoid Progress where+ mempty = Progress True 0 0 0 0 0 0 0 (0,0)+ mappend a b = Progress+ {isRunning = isRunning a && isRunning b+ ,countSkipped = countSkipped a + countSkipped b+ ,countBuilt = countBuilt a + countBuilt b+ ,countUnknown = countUnknown a + countUnknown b+ ,countTodo = countTodo a + countTodo b+ ,timeSkipped = timeSkipped a + timeSkipped b+ ,timeBuilt = timeBuilt a + timeBuilt b+ ,timeUnknown = timeUnknown a + timeUnknown b+ ,timeTodo = let (a1,a2) = timeTodo a; (b1,b2) = timeTodo b+ x1 = a1 + b1; x2 = a2 + b2+ in x1 `seq` x2 `seq` (x1,x2)+ }++-- Including timeSkipped gives a more truthful percent, but it drops more sharply+-- which isn't what users probably want+progressDone :: Progress -> Double+progressDone Progress{..} = timeBuilt+++-- | Make a guess at the number of seconds to go, ignoring multiple threads+progressTodo :: Progress -> Double+progressTodo Progress{..} =+ fst timeTodo + (if avgSamples == 0 || snd timeTodo == 0 then 0 else fromIntegral (snd timeTodo) * avgTime)+ where+ avgTime = (timeBuilt + fst timeTodo) / fromIntegral avgSamples+ avgSamples = countBuilt + countTodo - snd timeTodo+++-- | Given a sampling interval (in seconds) and a way to display the status message,+-- produce a function suitable for using as 'Development.Shake.shakeProgress'.+-- This function polls the progress information every /n/ seconds, produces a status+-- message and displays it using the display function.+--+-- Typical status messages will take the form of @1:25m (15%)@, indicating that the build+-- is predicted to complete in 1min 25sec, and 15% of the necessary build time has elapsed.+-- This function uses past observations to predict future behaviour, and as such, is only+-- guessing. The time is likely to go up as well as down, and will be less accurate from a+-- clean build (as the system has fewer past observations).+--+-- The current implementation is to predict the time remaining (based on 'timeTodo') and the+-- work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,+-- while time left is calculated by scaling @remaining@ by the observed work rate in this build,+-- namely @done / time_elapsed@.+progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()+progressDisplay sample disp prog = loop 0+ where+ loop steps = do+ p <- prog+ if not $ isRunning p then+ disp "Finished"+ else do+ disp $ if steps == 0+ then "Starting..."+ else let done = progressDone p+ todo = progressTodo p+ comp = if done == 0 then todo else sample * todo / (done / fromIntegral steps)+ (mins,secs) = divMod (ceiling comp) (60 :: Int)+ time = show mins ++ ":" ++ ['0' | secs < 10] ++ show secs+ perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int)+ in time ++ "m (" ++ perc ++ "%)" ++ "\a"+ threadDelay $ ceiling $ sample * 1000000+ loop $! steps+1+++-- | Set the title of the current console window to the given text. On Windows+-- this function uses the @SetConsoleTitle@ API, elsewhere it uses an xterm+-- escape sequence. This function may not work for all terminals.+progressTitlebar :: String -> IO ()+progressTitlebar x =+#ifdef mingw32_HOST_OS+ BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()+#else+ BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"+#endif+++-- | A simple method for displaying progress messages, suitable for using as+-- 'Development.Shake.shakeProgress'. This function writes the current progress to+-- the titlebar every five seconds. The function is defined as:+--+-- @+--progressSimple = 'progressDisplay' 5 'progressTitlebar'+-- @+progressSimple :: IO Progress -> IO ()+progressSimple = progressDisplay 5 progressTitlebar
Development/Shake/Storage.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables, PatternGuards, NamedFieldPuns, FlexibleInstances, MultiParamTypeClasses #-} {- This module stores the meta-data so its very important its always accurate We can't rely on getting any exceptions or termination at the end, so we'd better write out a journal@@ -11,6 +11,7 @@ import Development.Shake.Binary import Development.Shake.Locks+import Development.Shake.Types import Control.Arrow import Control.Exception as E@@ -34,23 +35,21 @@ -- Increment every time the on-disk format/semantics change, -- @i@ is for the users version number-databaseVersion i = "SHAKE-DATABASE-6-" ++ show (i :: Int) ++ "\r\n"+databaseVersion i = "SHAKE-DATABASE-8-" ++ show (i :: Int) ++ "\r\n" withStorage :: (Eq w, Eq k, Hashable k ,Binary w, BinaryWith w k, BinaryWith w v)- => (String -> IO ()) -- ^ Logging function- -> FilePath -- ^ File prefix to use- -> Int -- ^ User supplied version number- -> Maybe Double -- ^ How often to flush (Nothing = never, Just = seconds)+ => ShakeOptions -- ^ Storage options+ -> (String -> IO ()) -- ^ Logging function -> w -- ^ Witness -> (Map k v -> (k -> v -> IO ()) -> IO a) -- ^ Execute -> IO a-withStorage logger file version flush witness act = do- let dbfile = file <.> "database"- bupfile = file <.> "bup"- createDirectoryIfMissing True $ takeDirectory file+withStorage ShakeOptions{shakeVerbosity,shakeVersion,shakeFlush,shakeFiles} logger witness act = do+ let dbfile = shakeFiles <.> "database"+ bupfile = shakeFiles <.> "bup"+ createDirectoryIfMissing True $ takeDirectory shakeFiles -- complete a partially failed compress b <- doesFileExist bupfile@@ -68,18 +67,18 @@ unless (LBS.null src) $ do let good x = isAlphaNum x || x `elem` "-_ " let bad = LBS.takeWhile good $ LBS.take 50 src- putStr $ unlines+ outputErr $ unlines ["Error when reading Shake database " ++ dbfile ," Invalid version stamp detected" ," Expected: " ++ takeWhile good (LBS.unpack ver) ," Found : " ++ LBS.unpack bad- ,"All files will be rebuilt"]+ ,"All rules will be rebuilt"] continue h Map.empty else -- make sure you are not handling exceptions from inside join $ handleJust (\e -> if asyncException e then Nothing else Just e) (\err -> do msg <- showException err- putStrLn $ unlines $+ outputErr $ unlines $ ("Error when reading Shake database " ++ dbfile) : map (" "++) (lines msg) ++ ["All files will be rebuilt"]@@ -118,7 +117,8 @@ logger "Compression complete" continue h mp where- ver = LBS.pack $ databaseVersion version+ outputErr = when (shakeVerbosity >= Quiet) . putStr+ ver = LBS.pack $ databaseVersion shakeVersion writeChunk h s = do logger $ "Writing chunk " ++ show (LBS.length s)@@ -139,14 +139,14 @@ when (Map.null mp) $ reset h mp -- might as well, no data to lose, and need to ensure a good witness table lock <- newLock- flushThread flush h $ \out ->+ flushThread outputErr shakeFlush h $ \out -> act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v) -- We avoid calling flush too often on SSD drives, as that can be slow -- Do not move writes to a separate thread, as then we'd have to marshal exceptions back which is tricky-flushThread :: Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a-flushThread flush h act = do+flushThread :: (String -> IO ()) -> Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a+flushThread outputErr flush h act = do alive <- newVar True kick <- newEmptyMVar @@ -165,7 +165,7 @@ when b loop forkIO $ do let msg = "Warning: Flushing Shake journal failed, on abnormal termination you may lose some data, "- (loop >> return ()) `E.catch` \(e :: SomeException) -> putStrLn $ msg ++ show e+ (loop >> return ()) `E.catch` \(e :: SomeException) -> outputErr $ msg ++ show e ++ "\n" return () lock <- newLock
Development/Shake/Types.hs view
@@ -1,48 +1,17 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, PatternGuards #-} -- | Types exposed to the user module Development.Shake.Types( Progress(..), Verbosity(..), Assume(..), ShakeOptions(..), shakeOptions,- ShakeException(..)+ BS, pack, unpack, pack_, unpack_ ) where -import Control.Exception import Data.Data import Data.List----- | Information about the current state of the build, obtained by passing a callback function--- to 'shakeProgress'. Typically a program will poll this value to provide progress messages.--- The following example displays the approximate single-threaded time remaining--- as the console title.------ @---showProgress :: IO 'Progress' -> IO ()---showProgress progress = void $ forkIO loop--- where loop = do--- current <- progress--- when ('isRunning' current) $ do--- let (s,c) = timeTodo current--- setTitle $ \"Todo = \" ++ show (ceiling s) ++ \"s (+ \" ++ show c ++ \" unknown)\"--- threadDelay $ 5 * 1000000--- loop------setTitle :: String -> IO ()---setTitle s = putStr $ \"\\ESC]0;\" ++ s ++ \"\\BEL\"--- @-data Progress = Progress- {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.- ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.- ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.- ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.- ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.- ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.- ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.- ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.- ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).- }- deriving (Eq,Ord,Show,Data,Typeable)+import Development.Shake.Progress+import Development.Shake.Classes+import qualified Data.ByteString.Char8 as BS -- | The current assumptions made by the build system, used by 'shakeAssume'. These options@@ -108,27 +77,31 @@ ,shakeAssume :: Maybe Assume -- ^ Defaults to 'Nothing'. Assume all build objects are clean/dirty, see 'Assume' for details. -- Can be used to implement @make --touch@.+ ,shakeAbbreviations :: [(String,String)]+ -- ^ Defaults to @[]@. A list of substrings that should be abbreviated in status messages, and their corresponding abbreviation.+ -- Commonly used to replace the long paths (e.g. @.make/i586-linux-gcc/output@) with an abbreviation (e.g. @$OUT@). ,shakeProgress :: IO Progress -> IO ()- -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported,- -- see 'Progress' for details.+ -- ^ Defaults to no action. A function called on a separate thread when the build starts, allowing progress to be reported.+ -- For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced+ -- users should look at the 'Progress' data type. } deriving Typeable -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False (Just 10) Nothing (const $ return ())+shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False (Just 10) Nothing [] (const $ return ()) fieldsShakeOptions = ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"- ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeProgress"]+ ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeProgress"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 (fromProgress x11)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 (fromProgress x12) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) =- z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` ShakeProgress x11- gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+ gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) =+ z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` ShakeProgress x12+ gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions @@ -144,6 +117,7 @@ | Just x <- cast x = show (x :: Maybe FilePath) | Just x <- cast x = show (x :: Maybe Assume) | Just x <- cast x = show (x :: Maybe Double)+ | Just x <- cast x = show (x :: [(String,String)]) | Just x <- cast x = show (x :: ShakeProgress) | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x) @@ -163,25 +137,6 @@ tyShakeProgress = mkDataType "Development.Shake.Types.ShakeProgress" [] ---- NOTE: Not currently public, to avoid pinning down the API yet--- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing--- rules, will be raised using this exception type.-data ShakeException = ShakeException- [String] -- Entries on the stack, starting at the top of the stack.- SomeException -- Inner exception that was raised.- -- If I make these Haddock comments, then Haddock dies- deriving Typeable--instance Exception ShakeException--instance Show ShakeException where- show (ShakeException stack inner) = unlines $- "Error when running Shake build system:" :- map ("* " ++) stack ++- [show inner]-- -- | The verbosity data type, used by 'shakeVerbosity'. data Verbosity = Silent -- ^ Don't print any messages.@@ -191,3 +146,27 @@ | Diagnostic -- ^ Print messages for virtually everything (for debugging a build system). deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data) ++---------------------------------------------------------------------+-- BYTESTRING WRAPPER+-- Only purpose is because ByteString does not have an NFData instance in older GHC++newtype BS = BS BS.ByteString+ deriving (Hashable, Binary, Eq)++instance NFData BS where+ -- some versions of ByteString do not have NFData instances, but seq is equivalent+ -- for a strict bytestring. Therefore, we write our own instance.+ rnf (BS x) = x `seq` ()++pack :: String -> BS+pack = pack_ . BS.pack++unpack :: BS -> String+unpack = BS.unpack . unpack_++pack_ :: BS.ByteString -> BS+pack_ = BS++unpack_ :: BS -> BS.ByteString+unpack_ (BS x) = x
Development/Shake/Value.hs view
@@ -11,6 +11,7 @@ import Development.Shake.Binary import Development.Shake.Classes+import Development.Shake.Errors import Data.Typeable import Data.Bits@@ -46,8 +47,7 @@ fromKey (Key v) = fromValue v fromValue :: Typeable a => Value -> a-fromValue (Value x) = fromMaybe (error msg) $ cast x- where msg = "Internal error in Shake.fromValue, bad cast"+fromValue (Value x) = fromMaybe (err "fromValue, bad cast") $ cast x instance Show Key where show (Key a) = show a@@ -75,8 +75,8 @@ witness = unsafePerformIO $ newIORef Map.empty registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> IO ()-registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ error msg `asTypeOf` x) mp, ())- where msg = "Development.Shake.Value.registerWitness, witness of type " ++ show (typeOf x) ++ " demanded"+registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ err msg `asTypeOf` x) mp, ())+ where msg = "registerWitness, type " ++ show (typeOf x) -- Produce a list in a predictable order from a Map TypeRep, which should be consistent regardless of the order@@ -119,9 +119,8 @@ instance BinaryWith Witness Value where- -- FIXME: Should probably be writing out bytes, rather than 64 bit Int's putWith ws (Value x) = do- let msg = "Internal error, could not find witness type for " ++ show (typeOf x)+ let msg = "no witness for " ++ show (typeOf x) put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws) put x
Examples/C/Main.hs view
@@ -10,7 +10,7 @@ want [obj "Main.exe"] obj "Main.exe" *> \out -> do- cs <- getDirectoryFiles src "*.c"+ cs <- getDirectoryFiles src ["*.c"] let os = map (obj . (<.> "o")) cs need os system' "gcc" $ ["-o",out] ++ os
Examples/Self/Main.hs view
@@ -16,7 +16,7 @@ newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) -main :: IO ()+ main = shaken noTest $ \args obj -> do let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext want $ if null args then [obj "Main.exe"] else args@@ -25,7 +25,7 @@ let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x ghcPkg <- addOracle $ \GhcPkg{} -> do- (out,_) <- systemOutput "ghc-pkg" ["list","--simple-output"]+ (out,_) <- quietly $ systemOutput "ghc-pkg" ["list","--simple-output"] return $ words out ghcFlags <- addOracle $ \GhcFlags{} -> do
Examples/Tar/Main.hs view
@@ -5,7 +5,6 @@ import Examples.Util -main :: IO () main = shaken noTest $ \args obj -> do want [obj "result.tar"] obj "result.tar" *> \out -> do
Examples/Test/Assume.hs view
@@ -23,25 +23,21 @@ ask "abc" "abc" set 'b' 'd'- sleepFileTime- build ["abc.out"]+ build ["--sleep","abc.out"] ask "abc" "adc" set 'b' 'p'- sleepFileTime- build ["abc.out","--assume-clean"]+ build ["--sleep","abc.out","--assume-clean"] build ["abc.out"] ask "abc" "adc" set 'c' 'z'- sleepFileTime- build ["abc.out"]+ build ["--sleep","abc.out"] ask "abc" "apz" build ["bc.out","c.out"] ask "bc" "pz" set 'b' 'r' set 'c' 'n'- sleepFileTime- build ["abc.out","--assume-clean"]+ build ["--sleep","abc.out","--assume-clean"] ask "abc" "apz" build ["ab.out","--assume-dirty"] ask "ab" "ar"
Examples/Test/Basic.hs view
@@ -29,22 +29,19 @@ writeFile (obj "B.txt") "BBB" build ["AB.txt"] assertContents (obj "AB.txt") "AAABBB"- sleepFileTime appendFile (obj "A.txt") "aaa" build ["AB.txt"] assertContents (obj "AB.txt") "AAAaaaBBB" writeFile (obj "zero.txt") "xxx"- build ["twice.txt"]+ build ["twice.txt","--sleep"] assertContents (obj "twice.txt") "xxx"- sleepFileTime writeFile (obj "zero.txt") "yyy"- build ["once.txt"]+ build ["once.txt","--sleep"] assertContents (obj "twice.txt") "xxx" assertContents (obj "once.txt") "yyy"- sleepFileTime writeFile (obj "zero.txt") "zzz"- build ["once.txt","twice.txt"]+ build ["once.txt","twice.txt","--sleep"] assertContents (obj "twice.txt") "zzz" assertContents (obj "once.txt") "zzz"
Examples/Test/Directory.hs view
@@ -7,9 +7,9 @@ main = shaken test $ \args obj -> do- want $ map obj ["files.lst","dirs.lst","exist.lst"]+ want $ map obj ["files.lst","dirs.lst","exist.lst","foodirexist.lst"] obj "files.lst" *> \out -> do- x <- getDirectoryFiles (obj "") "*.txt"+ x <- getDirectoryFiles (obj "") ["*.txt"] writeFileLines out x obj "dirs.lst" *> \out -> do x <- getDirectoryDirs (obj "")@@ -18,7 +18,9 @@ xs <- readFileLines $ obj "files.lst" ys <- mapM (doesFileExist . obj) $ xs ++ map reverse xs writeFileLines out $ map show ys-+ obj "foodirexist.lst" *> \out -> do+ x <- doesDirectoryExist $ obj "Foo.txt"+ writeFileLines out [show x] test build obj = do build ["clean"]@@ -26,12 +28,13 @@ assertContents (obj "files.lst") $ unlines [] assertContents (obj "dirs.lst") $ unlines [] assertContents (obj "exist.lst") $ unlines []+ assertContents (obj "foodirexist.lst") $ unlines ["False"] writeFile (obj "A.txt") "" writeFile (obj "B.txt") "" createDirectory (obj "Foo.txt")- sleepFileTime- build []+ build ["--sleep"] assertContents (obj "files.lst") $ unlines ["A.txt","B.txt"] assertContents (obj "dirs.lst") $ unlines ["Foo.txt"] assertContents (obj "exist.lst") $ unlines ["True","True","False","False"]+ assertContents (obj "foodirexist.lst") $ unlines ["True"]
Examples/Test/Errors.hs view
@@ -58,6 +58,6 @@ crash ["staunch1","staunch2","--threads2"] ["crash"] b <- IO.doesFileExist $ obj "staunch1" assert (not b) "File should not exist, should have crashed first"- crash ["staunch1","staunch2","--threads2","--staunch"] ["crash"]+ crash ["staunch1","staunch2","--threads2","--staunch","--silent"] ["crash"] b <- IO.doesFileExist $ obj "staunch1" assert b "File should exist, staunch should have let it be created"
Examples/Test/FilePattern.hs view
@@ -29,6 +29,15 @@ substitute ["","test","da"] "//*a*.txt" === "testada.txt" substitute ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt" + directories1 "*.xml" === ("",False)+ directories1 "//*.xml" === ("",True)+ directories1 "foo//*.xml" === ("foo",True)+ directories1 "foo/bar/*.xml" === ("foo/bar",False)+ directories1 "*/bar/*.xml" === ("",True)+ directories ["*.xml","//*.c"] === [("",True)]+ directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]+ directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]+ --------------------------------------------------------------------- -- LAZY SMALLCHECK PROPERTIES
Examples/Test/Files.hs view
@@ -23,9 +23,8 @@ test build obj = do forM_ [[],["fun"]] $ \args -> do- sleepFileTime let nums = unlines . map show writeFile (obj "numbers.txt") $ nums [1,2,4,5,2,3,1]- build args+ build ("--sleep":args) assertContents (obj "even.txt") $ nums [2,4,2] assertContents (obj "odd.txt" ) $ nums [1,5,3,1]
Examples/Test/Journal.hs view
@@ -27,8 +27,7 @@ let change x = writeFile (obj $ x <.> "in") x let count x = do before <- readIORef rebuilt- build []- sleepFileTime+ build ["--sleep"] after <- readIORef rebuilt x === after - before
+ Examples/Test/Oracle.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}++module Examples.Test.Oracle(main) where++import Development.Shake+import Examples.Util+import Control.Exception+import Control.Monad+import Data.List+++main = shaken test $ \args obj -> do+ let f name lhs rhs = (,) name $+ (do addOracle $ \k -> let _ = k `asTypeOf` lhs in return rhs; return ()+ ,let o = obj name ++ ".txt" in do want [o]; o *> \_ -> do v <- askOracleWith lhs rhs; writeFile' o $ show v)+ let tbl = [f "str-bool" "" True+ ,f "str-int" "" (0::Int)+ ,f "bool-str" True ""+ ,f "int-str" (0::Int) ""]++ forM_ args $ \a -> case a of+ '+':x | Just (add,_) <- lookup x tbl -> add+ '*':x | Just (_,use) <- lookup x tbl -> use+ '@':key -> do addOracle $ \() -> return key; return ()+ '%':name -> let o = obj "unit.txt" in do want [o]; o *> \_ -> do {askOracleWith () ""; writeFile' o name}+++test build obj = do+ build ["clean"]++ -- check it rebuilds when it should+ build ["@key","%name"]+ assertContents (obj "unit.txt") "name"+ build ["@key","%test"]+ assertContents (obj "unit.txt") "name"+ build ["@foo","%test"]+ assertContents (obj "unit.txt") "test"++ -- check adding/removing redundant oracles does not trigger a rebuild+ build ["@foo","%newer","+str-bool"]+ assertContents (obj "unit.txt") "test"+ build ["@foo","%newer","+str-int"]+ assertContents (obj "unit.txt") "test"+ build ["@foo","%newer"]+ assertContents (obj "unit.txt") "test"++ -- check error messages are good+ let errors args err = do+ r <- try $ build args+ case r of+ Right _ -> error $ "Expected to fail but succeeded, wanted: " ++ err+ Left (msg :: SomeException)+ | err `isInfixOf` show msg -> return ()+ | otherwise -> error $ "Bad error message, wanted: " ++ err ++ ", got: " ++ show msg++ build ["+str-int","*str-int"]+ errors ["*str-int"] -- Building with an an Oracle that has been removed+ "missing a call to addOracle"++ errors ["*str-bool"] -- Building with an Oracle that I know nothing about+ "missing a call to addOracle"++ build ["+str-int","*str-int"]+ errors ["+str-bool","*str-int"] -- Building with an Oracle that has changed type+ "askOracle is used at the wrong type"++ errors ["+str-int","+str-bool"] -- Two Oracles with the same question type+ "Only one call to addOracle is allowed"++ errors ["+str-int","*str-bool"] -- Using an Oracle at the wrong answer type+ "askOracle is used at the wrong type"++ build ["+str-int","+str-int"] -- Two Oracles work if they aren't used+ errors ["+str-int","+str-int","*str-int"] -- Two Oracles fail if they are used+ "Only one call to addOracle is allowed"++ errors ["+str-int","+str-bool"] -- Two Oracles with the same answer type+ "Only one call to addOracle is allowed"
+ Examples/Test/Progress.hs view
@@ -0,0 +1,61 @@++module Examples.Test.Progress(main) where++import Development.Shake.Progress+import Examples.Util+import Data.IORef+import Data.Monoid+import Data.Char+++main = shaken test $ \args obj -> return ()+++-- | Given a list of todo times, get out a list of how long is predicted+prog = progEx 10000000000000000++progEx :: Double -> [Double] -> IO [Double]+progEx mxDone todo = do+ let scale = 100 -- Use scale so we can run the test faster+ let resolution = 10000 -- Use resolution to get extra detail on the numbers+ let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)+ pile <- newIORef $ zipWith (\t d -> mempty{timeBuilt=d,timeTodo=(t*scale*resolution,0)}) todo done+ let get = do a <- readIORef pile+ case a of+ [] -> return mempty{isRunning=False}+ x:xs -> do writeIORef pile xs; return x++ out <- newIORef []+ let put x = do let (mins,secs) = break (== ':') $ takeWhile (/= '(') x+ let f x = let y = filter isDigit x in if null y then 0/0 else read y+ modifyIORef out (++ [(f mins * 60 + f secs) / resolution])+ progressDisplay (1/scale) put get+ fmap (take $ length todo) $ readIORef out+++test build obj = do+ -- perfect functions should match perfectly+ xs <- prog [10,9..1]+ drop 2 xs === [8,7..1]+ xs <- prog $ map (*5) [10,9..1]+ drop 2 xs === [8,7..1]+ xs <- prog $ map (*0.2) [10,9..1]+ let dp3 x = fromIntegral (round $ x * 1000 :: Int) / 1000+ map dp3 (drop 2 xs) === [8,7..1]++ -- The properties below this line could be weakened++ -- increasing functions can't match+ xs <- prog [5,6,7]+ last xs === 700 -- because of the scale issues++ -- the first value must be plausible, or missing+ xs <- prog [187]+ assert (isNaN $ head xs) "No first value"++ -- desirable properties, could be weakened+ xs <- progEx 2 $ 100:map (*2) [10,9..1]+ drop 5 xs === [6,5..1]+ xs <- progEx 1 $ [10,9,100,8,7,6,5,4,3,2,1]+ assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"+
Examples/Test/Resources.hs view
@@ -7,12 +7,12 @@ import Data.IORef -main = do+main extra = do let cap = 2 ref <- newIORef 0 res <- newResource "test" cap- shaken test $ \args obj -> do+ flip (shaken test) extra $ \args obj -> do want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"] obj "*.txt" *> \out -> withResource res 1 $ do
Examples/Util.hs view
@@ -16,8 +16,10 @@ :: (([String] -> IO ()) -> (String -> String) -> IO ()) -> ([String] -> (String -> String) -> Rules ()) -> IO ()-shaken test rules = do+ -> IO ()+shaken test rules sleeper = do name:args <- getArgs+ when ("--sleep" `elem` args) sleeper putStrLn $ "## BUILD " ++ unwords (name:args) let out = "output/" ++ name ++ "/" createDirectoryIfMissing True out@@ -25,7 +27,7 @@ "test":extra -> do putStrLn $ "## TESTING " ++ name -- if the extra arguments are not --quiet/--loud it's probably going to go wrong- test (\args -> withArgs (name:args ++ extra) $ shaken test rules) (out++)+ test (\args -> withArgs (name:args ++ extra) $ shaken test rules sleeper) (out++) putStrLn $ "## FINISHED TESTING " ++ name "clean":_ -> removeDirectoryRecursive out {-@@ -49,10 +51,10 @@ args -> do (flags,args) <- return $ partition ("-" `isPrefixOf`) args flags <- return $ map (dropWhile (== '-')) flags- let f o x = case lookup x flagList of+ let f o x = case lookup x $ flagList name of Just op -> op o Nothing | "threads" `isPrefixOf` x -> o{shakeThreads=read $ drop 7 x}- | x == "clean" -> o -- handled elsewhere+ | x `elem` ["clean","sleep"] -> o -- handled elsewhere | otherwise -> error $ "Don't know how to deal with flag: " ++ x when ("clean" `elem` flags) $ removeDirectoryRecursive out let opts = foldl' f shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html"} flags@@ -60,11 +62,11 @@ flags :: [String]-flags = "threads#" : map fst flagList ++ ["clean"]+flags = "threads#" : map fst (flagList "") ++ ["clean","sleep"] -flagList :: [(String, ShakeOptions -> ShakeOptions)]-flagList = let (*) = (,) in+flagList :: String -> [(String, ShakeOptions -> ShakeOptions)]+flagList name = let (*) = (,) in ["no-dump" * \o -> o{shakeReport=Nothing} ,"silent" * \o -> o{shakeVerbosity=Silent} ,"quiet" * \o -> o{shakeVerbosity=Quiet}@@ -74,21 +76,13 @@ ,"staunch" * \o -> o{shakeStaunch=True} ,"deterministic" * \o -> o{shakeDeterministic=True} ,"lint" * \o -> o{shakeLint=True}- ,"stats" * \o -> o{shakeProgress=showProgress}+ ,"progress" * \o -> o{shakeProgress=progressSimple} ,"assume-clean" * \o -> o{shakeAssume=Just AssumeClean} ,"assume-dirty" * \o -> o{shakeAssume=Just AssumeDirty}+ ,"abbrev" * \o -> o{shakeAbbreviations=[(if name == "" then "output" else "output/" ++ name, "$OUT")]} ] -showProgress s = forkIO loop >> return ()- where loop = do- res <- s- when (isRunning res) $ do- let (s,c) = timeTodo res- putStrLn $ "PROGRESS: timeTodo = " ++ show (ceiling s) ++ "s (+ " ++ show c ++ " unknown)"- sleep 5- loop - unobj :: FilePath -> FilePath unobj = dropDirectory1 . dropDirectory1 @@ -109,7 +103,7 @@ noTest :: ([String] -> IO ()) -> (String -> String) -> IO () noTest build obj = do- build []+ build ["--abbrev"] build [] @@ -134,7 +128,7 @@ getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive dir = do xs <- IO.getDirectoryContents dir- (dirs,files) <- partitionM doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x]+ (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x] rest <- concatMapM getDirectoryContentsRecursive dirs return $ files++rest where
Main.hs view
@@ -1,9 +1,12 @@ module Main where +import Control.Concurrent+import Control.Monad+import Data.List import Data.Maybe import System.Environment -import Examples.Util(flags)+import Examples.Util(flags, sleepFileTime) import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self import qualified Examples.C.Main as C@@ -16,7 +19,9 @@ import qualified Examples.Test.FilePath as FilePath import qualified Examples.Test.FilePattern as FilePattern import qualified Examples.Test.Journal as Journal+import qualified Examples.Test.Oracle as Oracle import qualified Examples.Test.Pool as Pool+import qualified Examples.Test.Progress as Progress import qualified Examples.Test.Random as Random import qualified Examples.Test.Resources as Resources @@ -28,7 +33,8 @@ ,"basic" * Basic.main, "directory" * Directory.main, "errors" * Errors.main ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main ,"journal" * Journal.main, "pool" * Pool.main, "random" * Random.main- ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main]+ ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main+ ,"oracle" * Oracle.main, "progress" * Progress.main] where (*) = (,) @@ -48,14 +54,27 @@ ," main self --threads2 --loud" ,"" ,"Which will build Shake, using Shake, on 2 threads."]- Just main -> main+ Just main -> main sleepFileTime -clean :: IO ()-clean = sequence_ [withArgs [name,"clean"] main | (name,main) <- mains]+clean :: IO () -> IO ()+clean extra = sequence_ [withArgs [name,"clean"] $ main extra | (name,main) <- mains] -test :: IO ()-test = do+test :: IO () -> IO ()+test _ = do args <- getArgs- sequence_ [withArgs (name:"test":drop 1 args) main | (name,main) <- mains, name /= "random"]+ one <- newMVar () -- Only one may execute at a time+ let pause = do putMVar one (); sleepFileTime; takeMVar one+ let tests = filter ((/= "random") . fst) mains+ -- priority tests have more pauses in, so doing them sooner gets the whole tests done faster+ let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests+ dones <- forM (priority ++ normal) $ \(name,main) -> do+ done <- newEmptyMVar+ forkIO $ do+ takeMVar one+ withArgs (name:"test":drop 1 args) $ main pause+ putMVar one ()+ putMVar done ()+ return done+ mapM_ takeMVar dones
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: shake-version: 0.6+version: 0.7 license: BSD3 license-file: LICENSE category: Development@@ -100,6 +100,7 @@ Development.Shake.Database Development.Shake.Derived Development.Shake.Directory+ Development.Shake.Errors Development.Shake.File Development.Shake.FilePattern Development.Shake.Files@@ -108,6 +109,7 @@ Development.Shake.Locks Development.Shake.Oracle Development.Shake.Pool+ Development.Shake.Progress Development.Shake.Report Development.Shake.Rerun Development.Shake.Storage@@ -156,6 +158,8 @@ Examples.Test.FilePattern Examples.Test.Files Examples.Test.Journal+ Examples.Test.Oracle Examples.Test.Pool+ Examples.Test.Progress Examples.Test.Random Examples.Test.Resources