shake 0.1.3 → 0.1.4
raw patch · 19 files changed
+642/−172 lines, 19 filesdep +access-timedep +deepseq
Dependencies added: access-time, deepseq
Files
- Development/Shake.hs +16/−3
- Development/Shake/Core.hs +157/−60
- Development/Shake/Database.hs +29/−8
- Development/Shake/Directory.hs +18/−6
- Development/Shake/File.hs +68/−59
- Development/Shake/FilePath.hs +6/−7
- Development/Shake/FilePattern.hs +77/−0
- Development/Shake/FileTime.hs +52/−0
- Development/Shake/Files.hs +56/−0
- Development/Shake/Value.hs +9/−5
- Examples/Self/Main.hs +3/−3
- Examples/Tar/Main.hs +1/−1
- Examples/Test/Basic1.hs +36/−5
- Examples/Test/Directory.hs +2/−2
- Examples/Test/Errors.hs +44/−0
- Examples/Test/Files.hs +33/−0
- Examples/Util.hs +23/−10
- Main.hs +3/−1
- shake.cabal +9/−2
Development/Shake.hs view
@@ -20,18 +20,31 @@ module Development.Shake( shake, -- * Core of Shake- module Development.Shake.Core,+ ShakeOptions(..), shakeOptions,+ Rule(..), Rules, defaultRule, rule, action,+ Action, apply, apply1, traced,+ putLoud, putNormal, putQuiet,+ Observed(..),+ liftIO, -- * Utility functions module Development.Shake.Derived, -- * File rules- module Development.Shake.File,+ need, want, (*>), (**>), (?>),+ module Development.Shake.Files,+ FilePattern, (?==), -- * Directory rules- module Development.Shake.Directory+ doesFileExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs ) where +-- I would love to use module export in the above export list, but alas Haddock+-- then shows all the things that are hidden in the docs, which is terrible.++import Control.Monad.IO.Class import Development.Shake.Core hiding (run) import Development.Shake.Derived import Development.Shake.File hiding (defaultRuleFile)+import Development.Shake.FilePattern(FilePattern, (?==))+import Development.Shake.Files import Development.Shake.Directory hiding (defaultRuleDirectory) import qualified Development.Shake.Core as X
Development/Shake/Core.hs view
@@ -4,12 +4,15 @@ module Development.Shake.Core( ShakeOptions(..), shakeOptions, run, Rule(..), Rules, defaultRule, rule, action,- Action, apply, apply1, traced, currentStack, currentRule,- putLoud, putNormal, putQuiet+ Action, apply, apply1, traced,+ putLoud, putNormal, putQuiet,+ Observed(..) ) where import Prelude hiding (catch)+import Control.Arrow import Control.Concurrent.ParallelIO.Local+import Control.DeepSeq import Control.Exception import Control.Monad import Control.Monad.IO.Class@@ -17,6 +20,7 @@ import Data.Binary(Binary) import Data.Hashable import Data.Function+import Data.IORef import Data.List import qualified Data.HashMap.Strict as Map import Data.Maybe@@ -39,12 +43,14 @@ ,shakeParallel :: Int -- ^ What is the maximum number of rules I should run in parallel (defaults to @1@). ,shakeVersion :: Int -- ^ What is the version of your build system, increment to force a complete rebuild. ,shakeVerbosity :: Int -- ^ 1 = normal, 0 = quiet, 2 = loud.+ ,shakeLint :: Bool -- ^ Run under lint mode, when set implies 'shakeParallel' is @1@ (defaults to 'False').+ -- /This feature has not yet been completed, and should not be used./ } deriving (Show, Eq, Ord, Read) -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 1 1+shakeOptions = ShakeOptions ".shake" 1 1 1 False data ShakeException = ShakeException [Key] SomeException@@ -64,9 +70,10 @@ -- | Define a pair of types that can be used by Shake rules. class (- Show key, Typeable key, Eq key, Hashable key, Binary key,- Show value, Typeable value, Eq value, Hashable value, Binary value+ Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key,+ Show value, Typeable value, Eq value, Hashable value, Binary value, NFData value ) => Rule key value | key -> value where+ -- | Given that the database contains @key@/@value@, does that still match the on-disk contents? -- -- As an example for filenames/timestamps, if the file exists and had the same timestamp, you@@ -75,7 +82,37 @@ validStored :: key -> value -> IO Bool validStored _ _ = return True + -- | Return 'True' if the value should not be changed by the build system. Defaults to returning+ -- 'False'. Only used when running under lint mode.+ invariant :: key -> Bool+ invariant _ = False + -- | Given an action, return what has changed, along with what you think should+ -- have stayed the same. Only used when running under lint mode.+ observed :: IO a -> IO (Observed key, a)+ observed = fmap ((,) mempty)+++-- | Determine what was observed to change. For each field @Nothing@ means you don't know anything, while+-- @Just []@ means you know that nothing was changed/used.+data Observed a = Observed+ {changed :: Maybe [a] -- ^ A list of keys which had their value altered.+ ,used :: Maybe [a] -- ^ A list of keys whose value was used.+ }+ deriving (Show,Eq,Ord)++instance Functor Observed where+ fmap f (Observed a b) = Observed (g a) (g b)+ where g = fmap (map f)++instance Monoid (Observed a) where+ mempty = Observed Nothing Nothing+ mappend (Observed x1 y1) (Observed x2 y2) = Observed (f x1 x2) (f y1 y2)+ where+ f Nothing Nothing = Nothing+ f a b = Just $ fromMaybe [] a ++ fromMaybe [] b++ data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value)) ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key@@ -84,17 +121,22 @@ ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value ruleValue = undefined -ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> Bool)-ruleStored _ k v = unsafePerformIO $ validStored k v -- safe because of the invariants on validStored+ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> IO Bool)+ruleStored _ = validStored +ruleInvariant :: Rule key value => (key -> Maybe (Action value)) -> (key -> Bool)+ruleInvariant _ = invariant +ruleObserved :: Rule key value => (key -> Maybe (Action value)) -> (IO a -> IO (Observed key, a))+ruleObserved _ = observed++ -- | 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 using the 'Monad' instance and @do@ notation. data Rules a = Rules {value :: a -- not really used, other than for the Monad instance ,actions :: [Action ()]- -- FIXME: Should be Map TypeRep{k} (TypeRep{v}, [(Int,ARule)])- ,rules :: [(Int,ARule)] -- higher fst is higher priority+ ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule)]) -- higher fst is higher priority } instance Monoid a => Monoid (Rules a) where@@ -102,9 +144,12 @@ mappend a b = (a >> b){value = value a `mappend` value b} instance Monad Rules where- return x = Rules x [] []- Rules v1 x1 x2 >>= f = Rules v2 (x1++y1) (x2++y2)+ return x = Rules x [] (Map.fromList [])+ Rules v1 x1 x2 >>= f = Rules v2 (x1++y1) (Map.unionWith g x2 y2) where Rules v2 y1 y2 = f v1+ g (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 instance Functor Rules where fmap f x = return . f =<< x@@ -113,15 +158,21 @@ -- | Like 'rule', but lower priority, if no 'rule' exists then 'defaultRule' is checked. -- All default rules must be disjoint. defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-defaultRule r = mempty{rules=[(0,ARule r)]}+defaultRule = ruleWith 0 -- | Add a rule to build a key, returning an appropriate 'Action'. All rules must be disjoint. -- To define lower priority rules use 'defaultRule'. rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-rule r = mempty{rules=[(1,ARule r)]}+rule = ruleWith 1 +-- | Add a rule at a given priority.+ruleWith :: Rule key value => Int -> (key -> Maybe (Action value)) -> Rules ()+ruleWith i r = 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 ()]}@@ -135,10 +186,11 @@ {database :: Database ,pool :: Pool ,started :: UTCTime- ,stored :: Key -> Value -> Bool+ ,stored :: Key -> Value -> IO Bool ,execute :: Key -> Action Value ,outputLock :: Var () ,verbosity :: Int+ ,observer :: Key -> IO () -> IO () -- stack variables ,stack :: [Key] -- in reverse -- local variables@@ -155,16 +207,38 @@ -- | This function is not actually exported, but Haddock is buggy. Please ignore. run :: ShakeOptions -> Rules () -> IO ()-run ShakeOptions{..} rules = do+run opts@ShakeOptions{..} rs = do start <- getCurrentTime- registerWitnesses rules+ registerWitnesses rs outputLock <- newVar () withDatabase shakeFiles shakeVersion $ \database -> do- withPool shakeParallel $ \pool -> do- let s0 = S database pool start (createStored rules) (createExecute rules) outputLock shakeVerbosity [] [] 0 []- parallel_ pool $ map (wrapStack [] . runAction s0) (actions rules)+ withObserver database $ \observer ->+ withPool (if shakeLint then 1 else shakeParallel) $ \pool -> do+ let s0 = S database pool start stored execute outputLock shakeVerbosity observer [] [] 0 []+ if shakeLint+ then mapM_ (wrapStack [] . runAction s0 . applyKeyValue . return . fst) =<< allEntries database+ else parallel_ pool $ map (wrapStack [] . runAction s0) (actions rs)+ where+ stored = createStored rs+ execute = createExecute rs + withObserver database act+ | not shakeLint = act $ \key val -> val+ | otherwise = do+ ents <- allEntries database+ let invariants = [(k,v) | (k,v) <- ents, Just (_,_,(_,ARule r):_) <- [Map.lookup (typeKey k) $ rules rs], ruleInvariant r (fromKey k)]+ observe = createObserver rs+ badStart <- filterM (fmap not . uncurry stored) invariants+ seen <- newIORef ([] :: [(Key,[Observed Key])])+ act $ \key val -> do+ obs <- observe val+ atomicModifyIORef seen $ \xs -> ((key,obs):xs, ())+ badEnd <- filterM (fmap not . uncurry stored) invariants+ when (not $ null $ badStart ++ badEnd) $+ error "There were invariants that were broken" -- FIXME: Better error message+ -- FIXME: Check the seen pile against the database + wrapStack :: [Key] -> IO a -> IO a wrapStack stk act = catch act $ \(SomeException e) -> case cast e of Just s@ShakeException{} -> throw s@@ -173,40 +247,56 @@ registerWitnesses :: Rules () -> IO () registerWitnesses Rules{..} =- forM_ rules $ \(_, ARule r) -> do+ forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do registerWitness $ ruleKey r registerWitness $ ruleValue r -createStored :: Rules () -> (Key -> Value -> Bool)+createObserver :: Rules () -> (IO () -> IO [Observed Key])+createObserver Rules{..} = f os+ where+ os = [obs | (k,v,(_,ARule r):_) <- Map.elems rules, let obs = fmap (first $ fmap newKey) . ruleObserved r]+ f [] act = act >> return []+ f (o:os) act = do+ (x,xs) <- o $ f os act+ return $ [x | x /= mempty] ++ xs+++createStored :: Rules () -> (Key -> Value -> IO Bool) createStored Rules{..} = \k v ->- let (tk,tv) = (typeKey k, typeValue v)- msg = "Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++- ", perhaps you are missing a call to defaultRule/rule?"- in (fromMaybe (error msg) $ Map.lookup tk mp) k v- where mp = Map.fromList- [ (typeOf $ ruleKey r, stored)- | (_,ARule r) <- rules- , let stored k v = ruleStored r (fromKey k) (fromValue v)]+ let (tk,tv) = (typeKey k, typeValue v) in+ case Map.lookup tk mp of+ Nothing -> error $+ "Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv +++ ", perhaps you are missing a call to 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+ where+ mp = flip Map.map rules $ \(k,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx)) createExecute :: Rules () -> (Key -> Action Value) createExecute Rules{..} = \k ->- let tk = typeKey k- rs = fromMaybe [] $ Map.lookup tk mp- in case filter (not . null) $ map (mapMaybe ($ k)) rs of+ let tk = typeKey k in+ 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 [r]:_ -> r rs -> let s = if null rs then "no" else show (length $ head rs)- in error $ "Error: " ++ s ++ " rules match for Rule " ++ show tk ++- ", with key " ++ show k+ in error $ "Error: " ++ s ++ " rules match for Rule " ++ show k ++ " of type " ++ show tk where- mp = Map.map (map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)) $ Map.fromListWith (++)- [ (typeOf $ ruleKey r, [(i,exec)])- | (i,ARule r) <- rules- , let exec k = fmap (fmap newValue) $ r (fromKey k)]+ mp = flip Map.map rules $ \(_,_,rs) -> sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] + sets :: Ord a => [(a, b)] -> [[b]]+ sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + runAction :: S -> Action a -> IO (a, S) runAction s (Action x) = runStateT x s @@ -218,32 +308,37 @@ -- | 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 = Action $ do- modify $ \s -> s{depends=map newKey ks:depends s}+apply ks = fmap (map fromValue) $ applyKeyValue $ map newKey ks++applyKeyValue :: [Key] -> Action [Value]+applyKeyValue ks = Action $ do+ modify $ \s -> s{depends=ks:depends s} loop where loop = do s <- get- res <- liftIO $ request (database s) (stored s) $ map newKey ks+ let unsafeStored k v = unsafePerformIO $ stored s k v -- safe because of the invariants on validStored+ res <- liftIO $ request (database s) unsafeStored ks case res of- Block act -> discounted (liftIO $ extraWorkerWhileBlocked (pool s) act) >> loop- Response vs -> return $ map fromValue vs+ Block (seen,act) -> do+ let bad = intersect (stack s) seen+ if not $ null bad+ then error $ "Invalid rules, recursion detected when trying to build: " ++ show (head bad)+ else discounted (liftIO $ extraWorkerWhileBlocked (pool s) act) >> loop+ Response vs -> return vs Execute todo -> do- let bad = intersect (stack s) todo- if not $ null bad then- error $ "Invalid rules, recursion detected when trying to build: " ++ show (head bad)- else do- discounted $ liftIO $ parallel_ (pool s) $ flip map todo $ \t ->- wrapStack (reverse $ t:stack s) $ do- start <- getCurrentTime- let s2 = s{depends=[], stack=t:stack s, discount=0, traces=[]}- (res,s2) <- runAction s2 $ do- putNormal $ "# " ++ show t- execute s t- end <- getCurrentTime- let x = duration start end - discount s2- finished (database s) t res (reverse $ depends s2) x (reverse $ traces s2)- loop+ discounted $ liftIO $ parallel_ (pool s) $ flip map todo $ \t ->+ wrapStack (reverse $ t:stack s) $ observer s t $ do+ start <- getCurrentTime+ let s2 = s{depends=[], stack=t:stack s, discount=0, traces=[]}+ (res,s2) <- runAction s2 $ do+ putNormal $ "# " ++ show t+ execute s t+ evaluate $ rnf res+ end <- getCurrentTime+ let x = duration start end - discount s2+ finished (database s) t res (reverse $ depends s2) x (reverse $ traces s2)+ loop discounted x = do start <- liftIO getCurrentTime@@ -268,9 +363,11 @@ modify $ \s -> s{traces = (msg,duration (started s) start, duration (started s) stop):traces s} return res +{-+-- Do not provide currentStack/currentRule, since they return [Key], and Key isn't an exported type. -- | Get the stack of 'Key's for the current rule - usually used to improve error messages.--- Returns '[]' if being run by 'action', otherwise returns the stack with the oldest rule+-- Returns @[]@ if being run by 'action', otherwise returns the stack with the oldest rule -- first. currentStack :: Action [Key] currentStack = Action $ fmap reverse $ gets stack@@ -279,7 +376,7 @@ -- | Get the 'Key' for the currently executing rule - usally used to improve error messages. -- Returns 'Nothing' if being run by 'action'. currentRule = Action $ fmap listToMaybe $ gets stack-+-} putWhen :: (Int -> Bool) -> String -> Action () putWhen f msg = Action $ do
Development/Shake/Database.hs view
@@ -10,7 +10,8 @@ module Development.Shake.Database( Database, withDatabase,- request, Response(..), finished+ request, Response(..), finished,+ allEntries ) where import Development.Shake.Binary@@ -40,8 +41,8 @@ -- Increment every time the on-disk format/semantics change, -- @i@ is for the users version number-databaseVersion i = "SHAKE-DATABASE-1-" ++ show (i :: Int) ++ "\r\n"-journalVersion i = "SHAKE-JOURNAL-1-" ++ show (i :: Int) ++ "\r\n"+databaseVersion i = "SHAKE-DATABASE-2-" ++ show (i :: Int) ++ "\r\n"+journalVersion i = "SHAKE-JOURNAL-2-" ++ show (i :: Int) ++ "\r\n" removeFile_ :: FilePath -> IO ()@@ -83,18 +84,23 @@ | Loaded Info deriving Show +getInfo :: Status -> Maybe Info+getInfo (Built i) = Just i+getInfo (Loaded i) = Just i+getInfo (Building _ i) = i + --------------------------------------------------------------------- -- OPERATIONS data Response = Execute [Key] -- you need to execute these keys and call finished at least once before calling request again- | Block (IO ()) -- you need to block on at least one of these barriers before calling request again+ | Block ([Key], IO ()) -- you need to block on at least one of these barriers before calling request again | Response [Value] -- actual result values, do not call request again data Response_ = Response_ {execute :: [Key]- ,barriers :: [Barrier]+ ,barriers :: [(Key,Barrier)] ,values :: [(Time,Value)] } @@ -104,7 +110,7 @@ toResponse :: Response_ -> Response toResponse Response_{..} | not $ null execute = Execute execute- | not $ null barriers = Block $ waitAnyBarrier barriers+ | not $ null barriers = Block $ second waitAnyBarrier $ unzip barriers | otherwise = Response $ map snd values @@ -123,7 +129,7 @@ s <- S.get case Map.lookup k s of Nothing -> build k- Just (Building bar _) -> return $ Response_ [] [bar] []+ Just (Building bar _) -> return $ Response_ [] [(k,bar)] [] Just (Built i) -> return $ Response_ [] [] [(changed i, value i)] Just (Loaded i) -> if not $ validStored k (value i)@@ -160,9 +166,24 @@ releaseBarrier barrier +-- | Return a list of keys in an order which would build them bottom up. Relies on the invariant+-- that the database is not cyclic.+allEntries :: Database -> IO [(Key,Value)]+allEntries Database{..} = do+ status <- readVar status+ return $ ordering [((k, value i), concat $ depends i) | (k,v) <- Map.toList status, Just i <- [getInfo v]]+ where+ ordering :: Eq a => [((a,b), [a])] -> [(a,b)]+ ordering xs = f [(a, nub b `intersect` as) | let as = map (fst . fst) xs, (a,b) <- xs]+ where+ f xs | null xs = []+ | null now = error "Internal invariant broken, database seems to be cyclic (probably during lint)"+ | otherwise = let ns = map fst now in ns ++ f [(a,b \\ map fst ns) | (a,b) <- later]+ where (now,later) = partition (null . snd) xs++ --------------------------------------------------------------------- -- DATABASE- withDatabase :: FilePath -> Int -> (Database -> IO a) -> IO a withDatabase filename version = bracket (openDatabase filename version) closeDatabase
Development/Shake/Directory.hs view
@@ -6,6 +6,7 @@ defaultRuleDirectory ) where +import Control.DeepSeq import Control.Monad import Control.Monad.IO.Class import Data.Binary@@ -13,15 +14,14 @@ import Data.List import Data.Typeable import qualified System.Directory as IO-import System.FilePath import Development.Shake.Core-import Development.Shake.File-+import Development.Shake.FilePath+import Development.Shake.FilePattern newtype Exist = Exist FilePath- deriving (Typeable,Eq,Hashable,Binary)+ deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show Exist where show (Exist a) = "Exists? " ++ a@@ -31,10 +31,20 @@ = GetDir {dir :: FilePath} | GetDirFiles {dir :: FilePath, pat :: FilePattern} | GetDirDirs {dir :: FilePath}- deriving (Typeable,Show,Eq)+ deriving (Typeable,Eq) newtype GetDir_ = GetDir_ [FilePath]- deriving (Typeable,Show,Eq,Hashable,Binary)+ deriving (Typeable,Show,Eq,Hashable,Binary,NFData) +instance Show GetDir where+ show (GetDir x) = "Listing " ++ x+ show (GetDirFiles a b) = "Files " ++ a </> b+ show (GetDirDirs x) = "Dirs " ++ x++instance NFData GetDir where+ rnf (GetDir a) = rnf a+ rnf (GetDirFiles a b) = rnf a `seq` rnf b+ rnf (GetDirDirs a) = rnf a+ instance Hashable GetDir where hash = hash . f where f (GetDir x) = (0 :: Int, x, "")@@ -56,9 +66,11 @@ instance Rule Exist Bool where validStored (Exist x) b = fmap (== b) $ IO.doesFileExist x+ invariant _ = True instance Rule GetDir GetDir_ where validStored x y = fmap (== y) $ getDir x+ invariant _ = True -- | This function is not actually exported, but Haddock is buggy. Please ignore.
Development/Shake/File.hs view
@@ -1,61 +1,96 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-} module Development.Shake.File(- FilePattern, need, want,+ need, want, defaultRuleFile,- (?==), (*>), (**>), (?>)+ (*>), (**>), (?>) ) where +import Control.DeepSeq+import Control.Exception+import Control.Monad import Control.Monad.IO.Class import Data.Binary import Data.Hashable import Data.List+import Data.Maybe+import Data.Monoid import Data.Typeable import System.Directory-import System.Time import Development.Shake.Core-import System.FilePath(takeDirectory)+import Development.Shake.FilePath+import Development.Shake.FilePattern+import Development.Shake.FileTime --- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax--- and semantics of 'FilePattern' see '?=='.-type FilePattern = String- newtype File = File FilePath- deriving (Typeable,Eq,Hashable,Binary)--newtype FileTime = FileTime Int- deriving (Typeable,Show,Eq,Hashable,Binary)+ deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show File where show (File x) = x -getFileTime :: FilePath -> IO (Maybe FileTime)-getFileTime x = do- b <- doesFileExist x- if not b then return Nothing else do- TOD t _ <- getModificationTime x- return $ Just $ FileTime $ fromIntegral t+instance Rule File FileTime where+ validStored (File x) t = fmap (== Just t) $ getModTimeMaybe x -getFileTimeErr :: String -> FilePath -> IO FileTime-getFileTimeErr msg x = do- res <- getFileTime x- case res of- -- Important to raise an error in IO, not return a value which will error later- Nothing -> error $ msg ++ "\n" ++ x- Just x -> return x+ observed act = do+ src <- getCurrentDirectory+ old <- listDir src+ sleepFileTime+ res <- act+ new <- listDir src+ let obs = compareItems old new+ -- if we didn't find anything used, then most likely we aren't tracking access time close enough+ obs2 = obs{used = if used obs == Just [] then Nothing else (used obs)}+ return (obs2, res) +data Item = ItemDir [(String,Item)] -- sorted+ | ItemFile (Maybe FileTime) (Maybe FileTime) -- mod time, access time+ deriving Show -instance Rule File FileTime where- validStored (File x) t = fmap (== Just t) $ getFileTime x+listDir :: FilePath -> IO Item+listDir root = do+ xs <- getDirectoryContents root+ xs <- return $ sort $ filter (not . all (== '.')) xs+ fmap ItemDir $ forM xs $ \x -> fmap ((,) x) $ do+ let s = root </> x+ b <- doesFileExist s+ if b then listFile s else listDir s +listFile :: FilePath -> IO Item+listFile x = do+ let f x = Control.Exception.catch (fmap Just x) $ \(_ :: SomeException) -> return Nothing+ mod <- f $ getModTime x+ acc <- f $ getAccTime x+ return $ ItemFile mod acc +compareItems :: Item -> Item -> Observed File+compareItems = f ""+ where+ f path (ItemFile mod1 acc1) (ItemFile mod2 acc2) =+ Observed (Just [File path | mod1 /= mod2]) (Just [File path | acc1 /= acc2])+ f path (ItemDir xs) (ItemDir ys) = mconcat $ map g $ zips xs ys+ where g (name, Just x, Just y) = f (path </> name) x y+ g (name, x, y) = Observed (Just $ concatMap (files path) $ catMaybes [x,y]) Nothing+ f path _ _ = Observed (Just [File path]) Nothing++ files path (ItemDir xs) = concat [files (path </> a) b | (a,b) <- xs]+ files path _ = [File path]++ zips :: Ord a => [(a,b)] -> [(a,b)] -> [(a, Maybe b, Maybe b)]+ zips ((x1,x2):xs) ((y1,y2):ys)+ | x1 == y1 = (x1,Just x2,Just y2):zips xs ys+ | x1 < y1 = (x1,Just x2,Nothing):zips xs ((y1,y2):ys)+ | otherwise = (y1,Nothing,Just y2):zips ((x1,x2):xs) ys+ zips xs ys = [(a,Just b,Nothing) | (a,b) <- xs] ++ [(a,Nothing,Just b) | (a,b) <- ys]+++ -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleFile :: Rules () defaultRuleFile = defaultRule $ \(File x) -> Just $- liftIO $ getFileTimeErr "Error, file does not exist and no rule available:" x+ liftIO $ getModTimeError "Error, file does not exist and no rule available:" x -- | Require that the following files are built before continuing. Particularly@@ -91,12 +126,12 @@ if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x act x- liftIO $ getFileTimeErr "Error, rule failed to build the file:" x+ liftIO $ getModTimeError "Error, rule failed to build the file:" x --- | Define a set of patterns, and if any of them match, run the associate rule. See '*>'.+-- | Define a set of patterns, and if any of them match, run the associated rule. See '*>'. (**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(**>) test act = (\x -> any (x ?==) test) ?> act+(**>) test act = (\x -> any (?== x) test) ?> act -- | 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 '?=='.@@ -110,32 +145,6 @@ -- @.cpp.o@, @.hs.o@, to indicate which language produces an object file. -- I.e., the file @foo.cpp@ produces object file @foo.cpp.o@. --+-- Note that matching is case-sensitive, even on Windows. (*>) :: FilePattern -> (FilePath -> Action ()) -> Rules () (*>) test act = (test ?==) ?> act----- | Match a 'FilePattern' against a 'FilePath', There are only two special forms:------ * @*@ matches an entire path component, excluding any separators.------ * @\/\/@ matches an arbitrary number of path componenets.------ Some examples that match:------ > "//*.c" ?== "foo/bar/baz.c"--- > "*.c" ?== "baz.c"--- > "//*.c" ?== "baz.c"--- > "test.c" ?== "test.c"------ Examples that /don't/ match:------ > "*.c" ?== "foor/bar.c"--- > "*/*.c" ?== "foo/bar/baz.c"----(?==) :: FilePattern -> FilePath -> Bool-(?==) ('/':'/':x) y = any (x ?==) $ y : [i | '/':i <- tails y]-(?==) ('*':x) y = any (x ?==) $ a ++ take 1 b- where (a,b) = break ("/" `isPrefixOf`) $ tails y-(?==) (x:xs) (y:ys) | x == y = xs ?== ys-(?==) [] [] = True-(?==) _ _ = False
Development/Shake/FilePath.hs view
@@ -13,8 +13,7 @@ toNative, (</>), combine, ) where -import System.FilePath.Posix hiding (normalise, (</>), combine)-import qualified System.FilePath.Posix as Posix+import System.FilePath.Posix hiding (isPathSeparator, normalise, (</>), combine) import qualified System.FilePath as Native @@ -26,7 +25,7 @@ -- > dropDirectory1 "aaa" == "" -- > dropDirectory1 "" == "" dropDirectory1 :: FilePath -> FilePath-dropDirectory1 = drop 1 . dropWhile (not . isPathSeparator)+dropDirectory1 = drop 1 . dropWhile (not . Native.isPathSeparator) -- | Take the first component of a 'FilePath'. Should only be used on@@ -36,17 +35,17 @@ -- > takeDirectory1 "aaa/" == "aaa" -- > takeDirectory1 "aaa" == "aaa" takeDirectory1 :: FilePath -> FilePath-takeDirectory1 = takeWhile (not . isPathSeparator)+takeDirectory1 = takeWhile (not . Native.isPathSeparator) -- | Normalise a 'FilePath', translating any path separators to @\/@. normalise :: FilePath -> FilePath-normalise = map (\x -> if isPathSeparator x then '/' else x)+normalise = map (\x -> if Native.isPathSeparator x then '/' else x) -- | Convert to native path separators, namely @\\@ on Windows. toNative :: FilePath -> FilePath-toNative = map (\x -> if isPathSeparator x then Native.pathSeparator else x)+toNative = map (\x -> if Native.isPathSeparator x then Native.pathSeparator else x) -- | Combine two file paths, an alias for 'combine'.@@ -63,4 +62,4 @@ combine :: FilePath -> FilePath -> FilePath combine x ('.':'.':'/':y) = combine (takeDirectory x) y combine x ('.':'/':y) = combine x y-combine x y = Posix.combine x y+combine x y = normalise $ Native.combine (toNative x) (toNative y)
+ Development/Shake/FilePattern.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.FilePattern(+ FilePattern, (?==),+ compatible, extract, substitute+ ) where++import Data.List+++-- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax+-- and semantics of 'FilePattern' see '?=='.+type FilePattern = String+++-- | Match a 'FilePattern' against a 'FilePath', There are only two special forms:+--+-- * @*@ matches an entire path component, excluding any separators.+--+-- * @\/\/@ matches an arbitrary number of path componenets.+--+-- Some examples that match:+--+-- > "//*.c" ?== "foo/bar/baz.c"+-- > "*.c" ?== "baz.c"+-- > "//*.c" ?== "baz.c"+-- > "test.c" ?== "test.c"+--+-- Examples that /don't/ match:+--+-- > "*.c" ?== "foor/bar.c"+-- > "*/*.c" ?== "foo/bar/baz.c"+--+(?==) :: FilePattern -> FilePath -> Bool+(?==) ('/':'/':p) x = any (p ?==) $ x : [i | '/':i <- tails x]+(?==) ('*':p) x = any (p ?==) $ a ++ take 1 b+ where (a,b) = break ("/" `isPrefixOf`) $ tails x+(?==) (p:ps) (x:xs) | p == x = ps ?== xs+(?==) [] [] = True+(?==) _ _ = False+++-- | Do they have the same * and // counts in the same order+compatible :: [FilePattern] -> Bool+compatible [] = True+compatible (x:xs) = all ((==) (f x) . f) xs+ where+ f ('*':xs) = '*':f xs+ f ('/':'/':xs) = '/':f xs+ f (x:xs) = f xs+ f [] = []+++-- | Extract the items that match the wildcards. The pair must match with '?=='.+extract :: FilePattern -> FilePath -> [String]+extract p x = head $ f p x ++ [[]]+ where+ f ('/':'/':p) x = rest p $ ("",x) : [(pre++"/",i) | (pre,'/':i) <- zip (inits x) (tails x)]+ f ('*':p) x = rest p $ a ++ take 1 b+ where (a,b) = break (isPrefixOf "/" . snd) $ zip (inits x) (tails x)+ f (p:ps) (x:xs) | p == x = f ps xs+ f [] [] = [[]]+ f _ _ = []++ rest p xs = [(skip:res) | (skip,keep) <- xs, res <- f p keep]+++-- | Given the result of 'extract', substitute it back in to a 'compatible' pattern.+--+-- > p '?==' x ==> substitute (extract p x) p == x+substitute :: [String] -> FilePattern -> FilePath+substitute = f+ where+ f (a:as) ('/':'/':ps) = a ++ f as ps+ f (a:as) ('*':ps) = a ++ f as ps+ f as (p:ps) = p : f as ps+ f as [] = []
+ Development/Shake/FileTime.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.FileTime(+ FileTime, sleepFileTime,+ getModTime, getModTimeError, getModTimeMaybe,+ getAccTime+ ) where++import Control.Concurrent(threadDelay)+import Control.DeepSeq+import Data.Binary+import Data.Hashable+import Data.Typeable+import System.Directory+import System.Directory.AccessTime+import System.Time+++newtype FileTime = FileTime Int+ deriving (Typeable,Eq,Hashable,Binary,Show,NFData)+++getModTimeMaybe :: FilePath -> IO (Maybe FileTime)+getModTimeMaybe x = do+ b <- doesFileExist x+ if b then fmap Just $ getModTime x else return Nothing+++getModTimeError :: String -> FilePath -> IO FileTime+getModTimeError msg x = do+ res <- getModTimeMaybe x+ case res of+ -- Important to raise an error in IO, not return a value which will error later+ Nothing -> error $ msg ++ "\n" ++ x+ Just x -> return x+++getModTime :: FilePath -> IO FileTime+getModTime x = do+ TOD t _ <- getModificationTime x+ return $ FileTime $ fromIntegral t+++getAccTime :: FilePath -> IO FileTime+getAccTime x = do+ TOD t _ <- getAccessTime x+ return $ FileTime $ fromIntegral t+++-- | Sleep long enough for the modification time resolution to catch up+sleepFileTime :: IO ()+sleepFileTime = threadDelay 1000000 -- 1 second
+ Development/Shake/Files.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.Files(+ (*>>)+ ) where++import Control.DeepSeq+import Control.Monad+import Control.Monad.IO.Class+import Data.Binary+import Data.Hashable+import Data.Typeable++import Development.Shake.Core+import Development.Shake.File+import Development.Shake.FilePattern+import Development.Shake.FileTime+++newtype Files = Files [FilePath]+ deriving (Typeable,Eq,Hashable,Binary,NFData)++newtype FileTimes = FileTimes [FileTime]+ deriving (Typeable,Show,Eq,Hashable,Binary,NFData)++instance Show Files where show (Files xs) = unwords xs+++instance Rule Files FileTimes where+ validStored (Files xs) (FileTimes ts) = fmap (== map Just ts) $ mapM getModTimeMaybe xs+++-- | Define a rule for building multiple files at the same time.+-- As an example, a single invokation of GHC produces both @.hi@ and @.o@ files:+--+-- > ["*.o","*.hi"] *>> \[o,hi] -> do+-- > let hs = replaceExtension o "hs"+-- > need ... -- all files the .hs import+-- > system' "ghc" ["-c",hs]+--+-- However, in practice, it's usually easier to define rules with '*>' and make the @.hi@ depend+-- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must+-- have the same sequence of @\/\/@ and @*@ wildcards in the same order.+(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+ps *>> act+ | not $ compatible ps = error $+ "All patterns to *>> must have the same number and position of // and * wildcards\n" +++ unwords ps+ | otherwise = do+ forM ps $ \p ->+ p *> \file -> do+ apply1 $ Files $ map (substitute $ extract p file) ps :: Action FileTimes+ return ()+ rule $ \(Files xs) -> if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do+ act xs+ liftIO $ fmap FileTimes $ mapM (getModTimeError "Error, multi rule failed to build the file:") xs
Development/Shake/Value.hs view
@@ -10,6 +10,7 @@ ) where import Development.Shake.Binary+import Control.DeepSeq import Data.Hashable import Data.Typeable @@ -24,15 +25,15 @@ -- We deliberately avoid Typeable instances on Key/Value to stop them accidentally -- being used inside themselves newtype Key = Key Value- deriving (Eq,Hashable,BinaryWith Witness)+ deriving (Eq,Hashable,NFData,BinaryWith Witness) -data Value = forall a . (Eq a, Show a, Typeable a, Hashable a, Binary a) => Value a+data Value = forall a . (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => Value a -newKey :: (Eq a, Show a, Typeable a, Hashable a, Binary a) => a -> Key+newKey :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> Key newKey = Key . newValue -newValue :: (Eq a, Show a, Typeable a, Hashable a, Binary a) => a -> Value+newValue :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> Value newValue = Value typeKey :: Key -> TypeRep@@ -54,6 +55,9 @@ instance Show Value where show (Value a) = show a +instance NFData Value where+ rnf (Value a) = rnf a+ instance Hashable Value where hash (Value a) = hash (typeOf a) `xor` hash a @@ -70,7 +74,7 @@ witness :: IORef (Map.HashMap TypeRep Value) witness = unsafePerformIO $ newIORef Map.empty -registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a) => a -> IO ()+registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> IO () registerWitness x = modifyIORef witness $ Map.insert (typeOf x) (Value $ undefined `asTypeOf` x)
Examples/Self/Main.hs view
@@ -11,12 +11,12 @@ main :: IO ()-main = shaken noTest $ \obj -> do- let pkgs = "transformers binary unordered-containers parallel-io filepath directory process"+main = shaken noTest $ \args obj -> do+ let pkgs = "transformers binary unordered-containers parallel-io filepath directory process access-time deepseq" flags = map ("-package=" ++) $ words pkgs let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext- want [obj "Main.exe"]+ want $ if null args then [obj "Main.exe"] else args obj "/*.exe" *> \out -> do src <- readFileLines $ replaceExtension out "deps"
Examples/Tar/Main.hs view
@@ -6,7 +6,7 @@ main :: IO ()-main = shaken noTest $ \obj -> do+main = shaken noTest $ \args obj -> do want [obj "result.tar"] obj "result.tar" *> \out -> do contents <- readFileLines "Examples/Tar/list.txt"
Examples/Test/Basic1.hs view
@@ -4,21 +4,52 @@ import Development.Shake import Examples.Util -main = shaken test $ \obj -> do- want [obj "AB.txt"]+main = shaken test $ \args obj -> do+ want $ map obj args obj "AB.txt" *> \out -> do need [obj "A.txt", obj "B.txt"] text1 <- readFile' $ obj "A.txt" text2 <- readFile' $ obj "B.txt" writeFile' out $ text1 ++ text2 + obj "twice.txt" *> \out -> do+ let src = obj "once.txt"+ need [src, src]+ copyFile' src out + obj "once.txt" *> \out -> do+ src <- readFile' $ obj "zero.txt"+ writeFile' out src++ test build obj = do+ let f b pat file = assert (b == (pat ?== file)) $ show pat ++ " ?== " ++ show file ++ "\nEXPECTED: " ++ show b+ f True "//*.c" "foo/bar/baz.c"+ f True "*.c" "baz.c"+ f True "//*.c" "baz.c"+ f True "test.c" "test.c"+ f False "*.c" "foor/bar.c"+ f False "*/*.c" "foo/bar/baz.c"+ writeFile (obj "A.txt") "AAA" writeFile (obj "B.txt") "BBB"- build []+ build ["AB.txt"] assertContents (obj "AB.txt") "AAABBB"- sleep 1+ sleepFileTime appendFile (obj "A.txt") "aaa"- build []+ build ["AB.txt"] assertContents (obj "AB.txt") "AAAaaaBBB"++ writeFile (obj "zero.txt") "xxx"+ build ["twice.txt"]+ assertContents (obj "twice.txt") "xxx"+ sleepFileTime+ writeFile (obj "zero.txt") "yyy"+ build ["once.txt"]+ assertContents (obj "twice.txt") "xxx"+ assertContents (obj "once.txt") "yyy"+ sleepFileTime+ writeFile (obj "zero.txt") "zzz"+ build ["once.txt","twice.txt"]+ assertContents (obj "twice.txt") "zzz"+ assertContents (obj "once.txt") "zzz"
Examples/Test/Directory.hs view
@@ -6,7 +6,7 @@ import System.Directory(createDirectory) -main = shaken test $ \obj -> do+main = shaken test $ \args obj -> do want $ map obj ["files.lst","dirs.lst","exist.lst"] obj "files.lst" *> \out -> do x <- getDirectoryFiles (obj "") "*.txt"@@ -30,7 +30,7 @@ writeFile (obj "A.txt") "" writeFile (obj "B.txt") "" createDirectory (obj "Foo.txt")- sleep 1+ sleepFileTime build [] assertContents (obj "files.lst") $ unlines ["A.txt","B.txt"] assertContents (obj "dirs.lst") $ unlines ["Foo.txt"]
+ Examples/Test/Errors.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Examples.Test.Errors(main) where++import Development.Shake+import Examples.Util+import Control.Exception hiding (assert)+import Control.Monad+import Data.List+++main = shaken test $ \args obj -> do+ want $ map obj args++ obj "norule" *> \_ ->+ need [obj "norule_isavailable"]++ obj "failcreate" *> \_ ->+ return ()++ obj "recursive" *> \out ->+ need [out]++ obj "systemcmd" *> \_ ->+ system' "random_missing_command" []++ obj "stack1" *> \_ -> need [obj "stack2"]+ obj "stack2" *> \_ -> need [obj "stack3"]+ obj "stack3" *> \_ -> error "crash"+++test build obj = do+ let crash args parts = do+ res <- try $ build args+ case res of+ Left (err :: SomeException) -> let s = show err in forM_ parts $ \p ->+ assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p+ Right _ -> error "Expected an exception but succeeded"++ crash ["norule"] ["norule_isavailable"]+ crash ["failcreate"] ["failcreate"]+ crash ["recursive"] ["recursive"]+ crash ["systemcmd"] ["systemcmd","random_missing_command"]+ crash ["stack1"] ["stack1","stack2","stack3","crash"]
+ Examples/Test/Files.hs view
@@ -0,0 +1,33 @@++module Examples.Test.Files(main) where++import Development.Shake+import Development.Shake.FilePattern+import Examples.Util+import Data.List+++main = shaken test $ \args obj -> do+ want $ map obj ["even.txt","odd.txt"]+ map obj ["even.txt","odd.txt"] *>> \[evens,odds] -> do+ src <- readFileLines $ obj "numbers.txt"+ let (es,os) = partition even $ map read src+ writeFileLines evens $ map show es+ writeFileLines odds $ map show os+++test build obj = do+ assert (compatible []) "compatible"+ assert (compatible ["//*a.txt","foo//a*.txt"]) "compatible"+ assert (not $ compatible ["//*a.txt","foo//a*.*txt"]) "compatible"+ extract "//*a.txt" "foo/bar/testa.txt" === ["foo/bar/","test"]+ extract "//*a.txt" "testa.txt" === ["","test"]+ extract "//*a*.txt" "testada.txt" === ["","test","da"]+ substitute ["","test","da"] "//*a*.txt" === "testada.txt"+ substitute ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt"++ let nums = unlines . map show+ writeFile (obj "numbers.txt") $ nums [1,2,4,5,2,3,1]+ build []+ assertContents (obj "even.txt") $ nums [2,4,2]+ assertContents (obj "odd.txt" ) $ nums [1,5,3,1]
Examples/Util.hs view
@@ -1,21 +1,22 @@ -module Examples.Util where+module Examples.Util(module Examples.Util, sleepFileTime) where import Development.Shake import Development.Shake.FilePath+import Development.Shake.FileTime -import Control.Concurrent(threadDelay) import Control.Monad-import System.Directory+import System.Directory as IO import System.Environment shaken :: (([String] -> IO ()) -> (String -> String) -> IO ())- -> ((String -> String) -> Rules ())+ -> ([String] -> (String -> String) -> Rules ()) -> IO () shaken test rules = do name:args <- getArgs+ putStrLn $ "## BUILD " ++ unwords (name:args) let out = "output/" ++ name ++ "/" createDirectoryIfMissing True out case args of@@ -23,24 +24,36 @@ putStrLn $ "## TESTING " ++ name test (\args -> withArgs (name:args) $ shaken test rules) (out++) "clean":_ -> removeDirectoryRecursive out- _ -> withArgs args $ shake shakeOptions{shakeFiles=out} $ rules (out++)+ "lint":args -> do+ let dbfile = out ++ ".database"+ tempfile = "output/" ++ name ++ ".database"+ b <- IO.doesFileExist dbfile+ when b $ renameFile dbfile tempfile+ removeDirectoryRecursive out+ createDirectoryIfMissing True out+ when b $ renameFile tempfile dbfile+ shake shakeOptions{shakeFiles=out, shakeLint=True} $ rules args (out++)+ _ -> shake shakeOptions{shakeFiles=out} $ rules args (out++) unobj :: FilePath -> FilePath unobj = dropDirectory1 . dropDirectory1 +assert :: Bool -> String -> IO ()+assert b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg ++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = assert (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b++ assertContents :: FilePath -> String -> IO () assertContents file want = do got <- readFile file- when (want /= got) $ error $ "File contents are wrong: " ++ file ++ show (want,got)+ assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got noTest :: ([String] -> IO ()) -> (String -> String) -> IO () noTest build obj = do build [] build []---sleep :: Double -> IO ()-sleep x = threadDelay $ floor $ x * 1000000
Main.hs view
@@ -8,13 +8,15 @@ import qualified Examples.Self.Main as Self import qualified Examples.Test.Basic1 as Basic1 import qualified Examples.Test.Directory as Directory+import qualified Examples.Test.Errors as Errors+import qualified Examples.Test.Files as Files fakes = ["clean" * clean, "test" * test] where (*) = (,) mains = ["tar" * Tar.main, "self" * Self.main- ,"basic1" * Basic1.main, "directory" * Directory.main]+ ,"basic1" * Basic1.main, "directory" * Directory.main, "errors" * Errors.main, "files" * Files.main] where (*) = (,)
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake-version: 0.1.3+version: 0.1.4 license: BSD3 license-file: LICENSE category: Development@@ -62,7 +62,9 @@ bytestring, time, parallel-io,- transformers == 0.2.*+ transformers == 0.2.*,+ access-time == 0.1.*,+ deepseq == 1.1.* exposed-modules: Development.Shake@@ -75,6 +77,9 @@ Development.Shake.Derived Development.Shake.Directory Development.Shake.File+ Development.Shake.FilePattern+ Development.Shake.Files+ Development.Shake.FileTime Development.Shake.Locks Development.Shake.TypeHash Development.Shake.Value@@ -91,4 +96,6 @@ Examples.Self.Main Examples.Test.Basic1 Examples.Test.Directory+ Examples.Test.Errors+ Examples.Test.Files Examples.Tar.Main