shake (empty) → 0.0
raw patch · 15 files changed
+1213/−0 lines, 15 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, directory, filepath, hashable, old-time, parallel-io, process, time, transformers, unordered-containers
Files
- Development/Shake.hs +25/−0
- Development/Shake/Core.hs +245/−0
- Development/Shake/Database.hs +342/−0
- Development/Shake/Derived.hs +31/−0
- Development/Shake/Directory.hs +96/−0
- Development/Shake/File.hs +81/−0
- Development/Shake/FilePath.hs +51/−0
- Development/Shake/Locks.hs +68/−0
- Development/Shake/TypeHash.hs +30/−0
- Development/Shake/Value.hs +118/−0
- Examples/Tar/Main.hs +13/−0
- LICENSE +30/−0
- Main.hs +19/−0
- Setup.hs +2/−0
- shake.cabal +62/−0
+ Development/Shake.hs view
@@ -0,0 +1,25 @@++module Development.Shake(+ shake,+ module Development.Shake.Core,+ module Development.Shake.Derived,+ module Development.Shake.File,+ module Development.Shake.Directory+ ) where++import Development.Shake.Core hiding (runShake)+import Development.Shake.Derived+import Development.Shake.File hiding (defaultRuleFile)+import Development.Shake.Directory hiding (defaultRuleDirectory)++import qualified Development.Shake.Core as X+import qualified Development.Shake.File as X+import qualified Development.Shake.Directory as X++shake :: ShakeOptions -> Rules () -> IO ()+shake opts r = do+ X.runShake opts $ do+ r+ X.defaultRuleFile+ X.defaultRuleDirectory+ return ()
+ Development/Shake/Core.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE RecordWildCards, ExistentialQuantification, FunctionalDependencies, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}++module Development.Shake.Core(+ ShakeOptions(..), shakeOptions, runShake,+ Rule(..), Rules, defaultRule, rule, action,+ Action, apply, apply1, traced, currentRule,+ putLoud, putNormal, putQuiet+ ) where++import Control.Concurrent.ParallelIO.Local+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State+import Data.Binary(Binary)+import Data.Hashable+import Data.Function+import Data.List+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import Data.Monoid+import Data.Time.Clock+import Data.Typeable+import System.IO.Unsafe++import Development.Shake.Database+import Development.Shake.Locks+import Development.Shake.Value+++---------------------------------------------------------------------+-- OPTIONS++data ShakeOptions = ShakeOptions+ {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.@)+ ,shakeParallelism :: 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 everyone to rebuild+ ,shakeVerbosity :: Int -- ^ 1 = normal, 0 = quiet, 2 = loud+ }++shakeOptions :: ShakeOptions+shakeOptions = ShakeOptions "." 1 1 1+++---------------------------------------------------------------------+-- RULES++class (+ Show key, Typeable key, Eq key, Hashable key, Binary key,+ Show value, Typeable value, Eq value, Hashable value, Binary value+ ) => Rule key value | key -> value where+ validStored :: key -> value -> IO Bool+ validStored _ _ = return True+++data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value))++ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key+ruleKey = undefined++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+++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+ }++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 [] []+ Rules v1 x1 x2 >>= f = Rules v2 (x1++y1) (x2++y2)+ where Rules v2 y1 y2 = f v1+++-- accumulate the Rule instances from defaultRule and rule, and put them in+-- if no rules to build something then it's cache instance is dodgy anyway+defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()+defaultRule r = mempty{rules=[(0,ARule r)]}+++rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()+rule r = mempty{rules=[(1,ARule r)]}+++action :: Action a -> Rules ()+action a = mempty{actions=[a >> return ()]}+++---------------------------------------------------------------------+-- MAKE++data S = S+ -- global constants+ {database :: Database+ ,pool :: Pool+ ,started :: UTCTime+ ,stored :: Key -> Value -> Bool+ ,execute :: Key -> Action Value+ ,outputLock :: Var ()+ ,verbosity :: Int+ -- stack variables+ ,stack :: [Key] -- in reverse+ -- local variables+ ,depends :: [[Key]] -- built up in reverse+ ,discount :: Double+ ,traces :: [(String, Double, Double)] -- in reverse+ }++newtype Action a = Action (StateT S IO a)+ deriving (Functor, Monad, MonadIO)+++runShake :: ShakeOptions -> Rules () -> IO Double+runShake ShakeOptions{..} rules = do+ start <- getCurrentTime+ registerWitnesses rules+ database <- openDatabase shakeFiles shakeVersion+ outputLock <- newVar ()+ withPool shakeParallelism $ \pool -> do+ let state = S database pool start (createStored rules) (createExecute rules) outputLock shakeVerbosity [] [] 0 []+ parallel_ pool $ map (runAction state) (actions rules)+ closeDatabase database+ end <- getCurrentTime+ return $ duration start end+++registerWitnesses :: Rules () -> IO ()+registerWitnesses Rules{..} =+ forM_ rules $ \(_, ARule r) -> do+ registerWitness $ ruleKey r+ registerWitness $ ruleValue r+++createStored :: Rules () -> (Key -> Value -> 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)]+++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+ [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+ 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)]+++runAction :: S -> Action a -> IO (a, S)+runAction s (Action x) = runStateT x s+++duration :: UTCTime -> UTCTime -> Double+duration start end = fromRational $ toRational $ end `diffUTCTime` start+++apply :: Rule key value => [key] -> Action [value]+apply ks = Action $ do+ modify $ \s -> s{depends=map newKey ks:depends s}+ loop+ where+ loop = do+ s <- get+ res <- liftIO $ request (database s) (stored s) $ map newKey ks+ case res of+ Block act -> discounted (liftIO act) >> loop+ Response vs -> return $ map fromValue vs+ Execute todo -> do+ let bad = intersect (stack s) todo+ if not $ null bad then+ error $ unlines $ "Invalid rules, recursion detected:" :+ map ((" " ++) . show) (reverse (head bad:stack s))+ else do+ discounted $ liftIO $ parallel_ (pool s) $ flip map todo $ \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+ 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+ res <- x+ end <- liftIO getCurrentTime+ modify $ \s -> s{discount=discount s + duration start end}+++apply1 :: Rule key value => key -> Action value+apply1 = fmap head . apply . return+++traced :: String -> IO a -> Action a+traced msg act = Action $ do+ start <- liftIO getCurrentTime+ res <- liftIO act+ stop <- liftIO getCurrentTime+ modify $ \s -> s{traces = (msg,duration (started s) start, duration (started s) stop):traces s}+ return res+++currentRule :: Action (Maybe Key)+currentRule = Action $ do+ s <- get+ return $ listToMaybe $ stack s+++putWhen :: (Int -> Bool) -> String -> Action ()+putWhen f msg = Action $ do+ s <- get+ when (f $ verbosity s) $+ liftIO $ modifyVar_ (outputLock s) $ const $+ putStrLn msg+++putLoud, putNormal, putQuiet :: String -> Action ()+putLoud = putWhen (>= 2)+putNormal = putWhen (>= 1)+putQuiet = putWhen (>= 0)
+ Development/Shake/Database.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-unused-binds #-} -- for fields used just for docs+{-+Files stores the meta-data so its very important its always accurate+We can't rely on getting a Ctrl+C at the end, so we'd better write out a journal+But if we do happen to get a Ctrl+C then that is very handy+The journal is idempotent, i.e. if we replay the journal twice all is good+-}++module Development.Shake.Database(+ Database, openDatabase, closeDatabase,+ request, Response(..), finished+ ) where++import Development.Shake.Locks+import Development.Shake.Value++import Prelude hiding (catch)+import Control.Arrow+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import qualified Control.Monad.Trans.State as S+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Char+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import Data.List+import System.Directory+import System.IO+import qualified Data.ByteString.Lazy.Char8 as LBS+++-- 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"+++removeFile_ :: FilePath -> IO ()+removeFile_ x = catch (removeFile x) (\(e :: SomeException) -> return ())+++type Map = Map.HashMap++newtype Time = Time Int+ deriving (Eq,Ord,Show)++incTime (Time i) = Time $ i + 1++++-- | Invariant: The database does not have any cycles when a Key depends on itself+data Database = Database+ {status :: Var (Map Key Status)+ ,timestamp :: Time+ ,journal :: Journal+ ,filename :: FilePath+ ,version :: Int -- user supplied version+ }++data Info = Info+ {value :: Value -- the value associated with the Key+ ,time :: Time -- the timestamp for deciding if it's valid+ ,depends :: [[Key]] -- dependencies+ ,realTime :: Time -- when it was actually run+ ,execution :: Double -- how long it took when it was last run (seconds)+ ,traces :: [(String, Double, Double)] -- a trace of the expensive operations (start/end in seconds since beginning of run)+ }+ deriving Show+++data Status+ = Building Barrier (Maybe Info)+ | Built Info+ | Loaded Info+++---------------------------------------------------------------------+-- 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+ | Response [Value] -- actual result values, do not call request again++data Response_ = Response_+ {execute :: [Key]+ ,barriers :: [Barrier]+ ,values :: [(Time,Value)]+ }++concatResponse :: [Response_] -> Response_+concatResponse xs = Response_ (concatMap execute xs) (concatMap barriers xs) (concatMap values xs)++toResponse :: Response_ -> Response+toResponse Response_{..}+ | not $ null execute = Execute execute+ | not $ null barriers = Block $ waitAnyBarrier barriers+ | otherwise = Response $ map snd values+++-- The idea behind request is that we do as much as we can with a single lock, which reduces a clean+-- rebuild to an absolute minimum traversal in single-threaded fast-path code. We may pay more repeatedly+-- calling 'request', but the depth of the call graph is low so it shouldn't be an issue, and with additional+-- complexity it could be avoided.+request :: Database -> (Key -> Value -> Bool) -> [Key] -> IO Response+request Database{..} validStored ks =+ modifyVar status $ \v -> do+ (res, mp) <- S.runStateT (fmap concatResponse $ mapM f ks) v+ return (mp, toResponse res)+ where+ f :: Key -> S.StateT (Map Key Status) IO Response_+ f k = do+ s <- S.get+ case Map.lookup k s of+ Nothing -> build k+ Just (Building bar _) -> return $ Response_ [] [bar] []+ Just (Built i) -> return $ Response_ [] [] [(time i, value i)]+ Just (Loaded i) ->+ if not $ validStored k (value i)+ then build k+ else validHistory k i (depends i)++ validHistory :: Key -> Info -> [[Key]] -> S.StateT (Map Key Status) IO Response_+ validHistory k i [] = do+ S.modify $ Map.insert k $ Built i+ return $ Response_ [] [] [(time i, value i)]+ validHistory k i (x:xs) = do+ r@Response_{..} <- fmap concatResponse $ mapM f x+ if not $ null execute && null barriers then return r+ else if all ((<= time i) . fst) values then validHistory k i xs+ else build k++ build :: Key -> S.StateT (Map Key Status) IO Response_+ build k = do+ bar <- liftIO newBarrier+ S.modify $ \mp ->+ let info = case Map.lookup k mp of Nothing -> Nothing; Just (Loaded i) -> Just i+ in Map.insert k (Building bar info) mp+ return $ Response_ [k] [] []+++finished :: Database -> Key -> Value -> [[Key]] -> Double -> [(String,Double,Double)] -> IO ()+finished Database{..} k v depends duration traces = do+ let info = Info v timestamp depends timestamp duration traces+ (info2, barrier) <- modifyVar status $ \mp -> return $+ let Just (Building bar old) = Map.lookup k mp+ info2 = if isJust old && value (fromJust old) == value info then info{time=time $ fromJust old} else info+ in (Map.insert k (Built info2) mp, (info2, bar))+ appendJournal journal k info2+ releaseBarrier barrier+++---------------------------------------------------------------------+-- DATABASE++-- Files are named based on the FilePath, but with different extensions,+-- such as .database, .journal, .trace+openDatabase :: FilePath -> Int -> IO Database+openDatabase filename version = do+ let dbfile = filename ++ ".database"+ jfile = filename ++ ".journal"++ (timestamp, status) <- readDatabase dbfile version+ timestamp <- return $ incTime timestamp+ + b <- doesFileExist jfile+ (status,timestamp) <- if not b then return (status,timestamp) else do+ status <- replayJournal jfile version status+ removeFile_ jfile+ -- the journal potentially things at the current timestamp, so increment my timestamp+ writeDatabase dbfile version timestamp status+ return (status, incTime timestamp)++ status <- newVar status+ journal <- openJournal jfile version+ return Database{..}+++closeDatabase :: Database -> IO ()+closeDatabase Database{..} = do+ status <- readVar status+ writeDatabase (filename ++ ".database") version timestamp status+ closeJournal journal+++writeDatabase :: FilePath -> Int -> Time -> Map Key Status -> IO ()+writeDatabase file version timestamp status = do+ ws <- currentWitness+ LBS.writeFile file $+ (LBS.pack $ databaseVersion version) `LBS.append`+ encode (timestamp, Witnessed ws $ Statuses status)+++readDatabase :: FilePath -> Int -> IO (Time, Map Key Status)+readDatabase file version = do+ let zero = (Time 1, Map.fromList [])+ b <- doesFileExist file+ if not b+ then return zero+ else catch (do+ src <- readFileVer file $ databaseVersion version+ let (a,b) = decode src+ c = fromStatuses $ fromWitnessed b+ -- FIXME: The LBS.length shouldn't be necessary, but it is+ a `seq` c `seq` LBS.length src `seq` return (a,c)) $+ \(err :: SomeException) -> do+ putStrLn $ unlines $+ ("Error when reading Shake database " ++ file) :+ map (" "++) (lines $ show err) +++ ["All files will be rebuilt"]+ removeFile_ file -- so it doesn't error next time+ return zero+++---------------------------------------------------------------------+-- JOURNAL++data Journal = Journal+ {handle :: Var (Maybe Handle)+ ,journalFile :: FilePath+ ,witness :: Witness+ }++openJournal :: FilePath -> Int -> IO Journal+openJournal journalFile ver = do+ h <- openFile journalFile WriteMode+ hSetFileSize h 0+ LBS.hPut h $ LBS.pack $ journalVersion ver+ witness <- currentWitness+ writeChunk h $ encode witness+ hFlush h+ handle <- newVar $ Just h+ return Journal{..}+++replayJournal :: FilePath -> Int -> Map Key Status -> IO (Map Key Status)+replayJournal file ver mp = catch (do+ src <- readFileVer file $ journalVersion ver+ let ws:rest = readChunks src+ ws <- return $ decode ws+ rest <- return $ map (runGet (getWitness ws)) rest+ return $ foldl' (\mp (k,v) -> Map.insert k (Loaded v) mp) mp rest)+ $ \(err :: SomeException) -> do+ putStrLn $ unlines $+ ("Error when reading Shake journal " ++ file) :+ map (" "++) (lines $ show err) +++ ["All files built in the last exceution will be rebuilt"]+ return mp+++appendJournal :: Journal -> Key -> Info -> IO ()+appendJournal Journal{..} k i = modifyVar_ handle $ \v -> case v of+ Nothing -> return Nothing+ Just h -> do+ writeChunk h $ runPut $ putWitness witness (k,i)+ return $ Just h+++closeJournal :: Journal -> IO ()+closeJournal Journal{..} =+ modifyVar_ handle $ \v -> case v of+ Nothing -> return Nothing+ Just h -> do+ hClose h+ removeFile_ journalFile+ return Nothing+++---------------------------------------------------------------------+-- SERIALISATION++instance Binary Time where+ put (Time i) = put i+ get = fmap Time get+++data Witnessed a = Witnessed Witness a+fromWitnessed (Witnessed _ x) = x++instance BinaryWitness a => Binary (Witnessed a) where+ put (Witnessed ws x) = put ws >> putWitness ws x+ get = do ws <- get; x <- getWitness ws; return $ Witnessed ws x++-- Only for serialisation+newtype Statuses = Statuses {fromStatuses :: Map Key Status}++instance BinaryWitness Statuses where+ putWitness ws (Statuses x) = putWitness ws [(k,i) | (k,v) <- Map.toList x, Just i <- [f v]]+ where+ f (Building _ i) = i+ f (Built i) = Just i+ f (Loaded i) = Just i+ getWitness ws = do+ x <- getWitness ws+ return $ Statuses $ Map.fromList $ map (second Loaded) x++instance BinaryWitness Info where+ putWitness ws (Info x1 x2 x3 x4 x5 x6) = putWitness ws x1 >> put x2 >> putWitness ws x3 >> put x4 >> put x5 >> put x6+ getWitness ws = do x1 <- getWitness ws; x2 <- get; x3 <- getWitness ws; x4 <- get; x5 <- get; x6 <- get; return $ Info x1 x2 x3 x4 x5 x6++instance (BinaryWitness a, BinaryWitness b) => BinaryWitness (a,b) where+ putWitness ws (a,b) = putWitness ws a >> putWitness ws b+ getWitness ws = do a <- getWitness ws; b <- getWitness ws; return (a,b)++instance BinaryWitness a => BinaryWitness [a] where+ putWitness ws xs = put (length xs) >> mapM_ (putWitness ws) xs+ getWitness ws = do n <- get; replicateM n $ getWitness ws+++readFileVer :: FilePath -> String -> IO LBS.ByteString+readFileVer file ver = do+ let ver2 = LBS.pack ver+ src <- LBS.readFile file+ unless (ver2 `LBS.isPrefixOf` src) $ do+ let bad = LBS.takeWhile (\x -> isAlphaNum x || x `elem` "-_ ") $ LBS.take 50 src+ error $ "Invalid version stamp\n" +++ "Expected: " ++ ver ++ "\n" +++ "Got : " ++ LBS.unpack bad+ return $ LBS.drop (fromIntegral $ length ver) src+++readChunks :: LBS.ByteString -> [LBS.ByteString]+readChunks x+ | Just (n, x) <- grab 4 x+ , Just (y, x) <- grab (fromIntegral (decode n :: Word32)) x+ = y : readChunks x+ | otherwise = []+ where+ grab i x | LBS.length a == i = Just (a, b)+ | otherwise = Nothing+ where (a,b) = LBS.splitAt i x+++writeChunk :: Handle -> LBS.ByteString -> IO ()+writeChunk h x = do+ let n = encode (fromIntegral $ LBS.length x :: Word32)+ LBS.hPut h $ n `LBS.append` x+ hFlush h
+ Development/Shake/Derived.hs view
@@ -0,0 +1,31 @@++module Development.Shake.Derived where++import Control.Monad+import Control.Monad.IO.Class+import System.Cmd+import System.Exit++import Development.Shake.Core+import Development.Shake.File+import Development.Shake.FilePath+++system_ :: [String] -> Action ()+system_ (x:xs) = do+ let cmd = unwords $ toNative x : xs+ putLoud cmd+ res <- liftIO $ system cmd+ when (res /= ExitSuccess) $ do+ k <- currentRule+ error $ "System command failed while building " ++ show k ++ ", " ++ cmd+++readFile_ :: FilePath -> Action String+readFile_ x = do+ need [x]+ liftIO $ readFile x+++readFileLines :: FilePath -> Action [String]+readFileLines = fmap lines . readFile_
+ Development/Shake/Directory.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.Directory(+ doesFileExist,+ getDirectoryContents, getDirectoryFiles, getDirectoryDirs,+ defaultRuleDirectory+ ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Binary+import Data.Hashable+import Data.List+import Data.Typeable+import qualified System.Directory as IO+import System.FilePath++import Development.Shake.Core+import Development.Shake.File++++newtype Exist = Exist FilePath+ deriving (Typeable,Show,Eq,Hashable,Binary)+newtype Exist_ = Exist_ Bool+ deriving (Typeable,Show,Eq,Hashable,Binary)+++data GetDir+ = GetDir {dir :: FilePath}+ | GetDirFiles {dir :: FilePath, pat :: FilePattern}+ | GetDirDirs {dir :: FilePath}+ deriving (Typeable,Show,Eq)+newtype GetDir_ = GetDir_ [FilePath]+ deriving (Typeable,Show,Eq,Hashable,Binary)++instance Hashable GetDir where+ hash = hash . f+ where f (GetDir x) = (0 :: Int, x, "")+ f (GetDirFiles x y) = (1, x, y)+ f (GetDirDirs x) = (2, x, "")++instance Binary GetDir where+ get = do+ i <- getWord8+ case i of+ 0 -> liftM GetDir get+ 1 -> liftM2 GetDirFiles get get+ 2 -> liftM GetDirDirs get++ put (GetDir x) = putWord8 0 >> put x+ put (GetDirFiles x y) = putWord8 1 >> put x >> put y+ put (GetDirDirs x) = putWord8 2 >> put x+++instance Rule Exist Exist_ where+ validStored (Exist x) (Exist_ b) = fmap (== b) $ IO.doesFileExist x++instance Rule GetDir GetDir_ where+ validStored x y = fmap (== y) $ getDir x+++defaultRuleDirectory :: Rules ()+defaultRuleDirectory = do+ defaultRule $ \(Exist x) -> Just $+ liftIO $ fmap Exist_ $ IO.doesFileExist x+ defaultRule $ \x@GetDir{} -> Just $+ liftIO $ getDir x+++doesFileExist :: FilePath -> Action Bool+doesFileExist x = do+ Exist_ y <- apply1 $ Exist x+ return y++getDirectoryContents :: FilePath -> Action [FilePath]+getDirectoryContents x = getDirAction $ GetDir x++getDirectoryFiles :: FilePath -> FilePattern -> Action [FilePath]+getDirectoryFiles x f = getDirAction $ GetDirFiles x f++getDirectoryDirs :: FilePath -> Action [FilePath]+getDirectoryDirs x = getDirAction $ GetDirDirs x++getDirAction x = do GetDir_ y <- apply1 x; return y+++getDir :: GetDir -> IO GetDir_+getDir x = fmap (GetDir_ . sort) $ f x . filter validName =<< IO.getDirectoryContents (dir x)+ where+ validName = not . all (== '.')++ f GetDir{} xs = return xs+ f GetDirFiles{} xs = flip filterM xs $ \s -> do+ 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
+ Development/Shake/File.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.File(+ FilePattern, need, want,+ defaultRuleFile,+ (=*=), (?>), (**>), (*>)+ ) where++import Control.Monad.IO.Class+import Data.Binary+import Data.Hashable+import Data.List+import Data.Typeable+import System.Directory+import System.Time++import Development.Shake.Core+++type FilePattern = String++newtype File = File FilePath+ deriving (Typeable,Eq,Hashable,Binary)++newtype FileTime = FileTime Int+ deriving (Typeable,Show,Eq,Hashable,Binary)++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) $ getFileTime x+++defaultRuleFile :: Rules ()+defaultRuleFile = defaultRule $ \(File x) -> Just $ do+ res <- liftIO $ getFileTime x+ case res of+ Nothing -> error $ "Error, file does not exist and no available rule: " ++ x+ Just t -> return t+++need :: [FilePath] -> Action ()+need xs = (apply $ map File xs :: Action [FileTime]) >> return ()++want :: [FilePath] -> Rules ()+want xs = action $ need xs+++(?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()+(?>) test act = rule $ \(File x) ->+ if not $ test x then Nothing else Just $ do+ act x+ res <- liftIO $ getFileTime x+ case res of+ Nothing -> error $ "Error, rule failed to build the file: " ++ x+ Just t -> return t+++(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+(**>) test act = (\x -> any (x =*=) test) ?> act++(*>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()+(*>) test act = (test =*=) ?> act+++(=*=) :: 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
@@ -0,0 +1,51 @@++-- | Module for 'FilePath' operations, to be used in place of+-- "System.FilePath". It uses @\/@ as the directory separator to ensure+-- uniqueness, and squashes any @\/.\/@ components.+module Development.Shake.FilePath(+ module System.FilePath.Posix,+ dropDirectory1, takeDirectory1, normalise,+ toNative, (</>), combine,+ ) where++import System.FilePath.Posix hiding (normalise, (</>), combine)+import qualified System.FilePath.Posix as Posix+import qualified System.FilePath as Native+++-- | Drop the first directory from a 'FilePath'. Should only be used on+-- relative paths.+--+-- > dropDirectory1 "aaa/bbb" == "bbb"+-- > dropDirectory1 "aaa/" == ""+-- > dropDirectory1 "aaa" == ""+-- > dropDirectory1 "" == ""+dropDirectory1 :: FilePath -> FilePath+dropDirectory1 = drop 1 . dropWhile (not . isPathSeparator)+++-- | Take the first component of a 'FilePath'. Should only be used on+-- relative paths.+--+-- > takeDirectory1 "aaa/bbb" == "aaa"+-- > takeDirectory1 "aaa/" == "aaa"+-- > takeDirectory1 "aaa" == "aaa"+takeDirectory1 :: FilePath -> FilePath+takeDirectory1 = takeWhile (not . isPathSeparator)+++normalise :: FilePath -> FilePath+normalise = map (\x -> if x == '\\' then '/' else x)+++toNative :: FilePath -> FilePath+toNative = map (\x -> if x == '/' then Native.pathSeparator else x)+++(</>) :: FilePath -> FilePath -> FilePath+(</>) = combine+++combine :: FilePath -> FilePath -> FilePath+combine x ('.':'.':'/':y) = combine (takeDirectory x) y+combine x y = Posix.combine x y
+ Development/Shake/Locks.hs view
@@ -0,0 +1,68 @@++module Development.Shake.Locks(+ Var, newVar, readVar, modifyVar, modifyVar_,+ Barrier, newBarrier, releaseBarrier, waitBarrier, waitAnyBarrier+ ) where++import Control.Concurrent+import Control.Monad+import Data.IORef+++---------------------------------------------------------------------+-- VAR++-- | Like an MVar, but must always be full+newtype Var a = Var (MVar a)++newVar :: a -> IO (Var a)+newVar = fmap Var . newMVar++readVar :: Var a -> IO a+readVar (Var x) = readMVar x++modifyVar :: Var a -> (a -> IO (a, b)) -> IO b+modifyVar (Var x) f = modifyMVar x f++modifyVar_ :: Var a -> (a -> IO a) -> IO ()+modifyVar_ (Var x) f = modifyMVar_ x f+++---------------------------------------------------------------------+-- BARRIER++-- Either Nothing to indicate it has been released already,+-- or Just the list of actions to run when released+newtype Barrier = Barrier (IORef (Maybe [IO ()]))++newBarrier :: IO Barrier+newBarrier = fmap Barrier $ newIORef $ Just []+++releaseBarrier :: Barrier -> IO ()+releaseBarrier (Barrier v) = do+ xs <- atomicModifyIORef v $ \v -> (Nothing, v)+ sequence_ $ maybe [] reverse xs+++waitBarrier :: Barrier -> IO ()+waitBarrier (Barrier v) = do+ i <- newEmptyMVar+ b <- atomicModifyIORef v $ \v -> case v of+ Nothing -> (Nothing, False)+ Just xs -> (Just $ putMVar i ():xs, True)+ when b $ takeMVar i+++waitAnyBarrier :: [Barrier] -> IO ()+waitAnyBarrier bs = do+ i <- newEmptyMVar + ref <- newIORef True+ let f = do+ b <- atomicModifyIORef ref $ \x -> (False,x)+ when b $ putMVar i ()+ b <- fmap and $ forM bs $ \(Barrier v) ->+ atomicModifyIORef v $ \v -> case v of+ Nothing -> (Nothing, False)+ Just xs -> (Just $ f:xs, True)+ when b $ takeMVar i
+ Development/Shake/TypeHash.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}++{- |+This module just contains the hash function on TypeRep. In future versions+of the hashable package it is available in Data.Hashable.+-}+module Development.Shake.TypeHash() where++import Data.Hashable++#if __GLASGOW_HASKELL__ < 702++import Data.Typeable+import System.IO.Unsafe++typeHash x = unsafePerformIO $ typeRepKey x++#else++import GHC.Fingerprint.Type(Fingerprint(..))+import Data.Typeable.Internal(TypeRep(..))++typeHash (TypeRep (Fingerprint x _) _ _) = fromIntegral x++#endif++typeHash :: TypeRep -> Int++instance Hashable TypeRep where+ hash = typeHash
+ Development/Shake/Value.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-}++{- |+This module implements the Key/Value types, to abstract over hetrogenous data types.+-}+module Development.Shake.Value(+ Value, newValue, fromValue, typeValue,+ Key, newKey, fromKey, typeKey,+ Witness, BinaryWitness(..), currentWitness, registerWitness+ ) where++import Data.Binary+import Data.Hashable+import Data.Typeable++import Data.Bits+import Data.IORef+import Data.Maybe+import qualified Data.HashMap.Strict as Map+import Development.Shake.TypeHash()+import System.IO.Unsafe+++-- We deliberately avoid Typeable instances on Key/Value to stop them accidentally+-- being used inside themselves+newtype Key = Key Value+ deriving (Eq,Hashable,BinaryWitness)++data Value = forall a . (Eq a, Show a, Typeable a, Hashable a, Binary a) => Value a+++newKey :: (Eq a, Show a, Typeable a, Hashable a, Binary a) => a -> Key+newKey = Key . newValue++newValue :: (Eq a, Show a, Typeable a, Hashable a, Binary a) => a -> Value+newValue = Value++typeKey :: Key -> TypeRep+typeKey (Key v) = typeValue v++typeValue :: Value -> TypeRep+typeValue (Value x) = typeOf x++fromKey :: Typeable a => Key -> a+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"++instance Show Key where+ show (Key a) = show a++instance Show Value where+ show (Value a) = show a++instance Hashable Value where+ hash (Value a) = hash (typeOf a) `xor` hash a++instance Eq Value where+ Value a == Value b = case cast b of+ Just bb -> a == bb+ Nothing -> False+++---------------------------------------------------------------------+-- BINARY INSTANCES++{-# NOINLINE witness #-}+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 x = modifyIORef witness $ Map.insert (typeOf x) (Value $ undefined `asTypeOf` x)+++data Witness = Witness+ {typeNames :: [String] -- the canonical data, the names of the types+ ,witnessIn :: Map.HashMap Int Value -- for reading in, the find the values (some may be missing)+ ,witnessOut :: Map.HashMap TypeRep Int -- for writing out, find the value+ }+++currentWitness :: IO Witness+currentWitness = do+ ws <- readIORef witness+ let (ks,vs) = unzip $ Map.toList ws+ return $ Witness (map show ks) (Map.fromList $ zip [0..] vs) (Map.fromList $ zip ks [0..])+++instance Binary Witness where+ put (Witness ts _ _) = put ts+ get = do+ ts <- get+ let ws = Map.toList $ unsafePerformIO $ readIORef witness+ let (is,ks,vs) = unzip3 [(i,k,v) | (i,t) <- zip [0..] ts, (k,v):_ <- [filter ((==) t . show . fst) ws]]+ return $ Witness ts (Map.fromList $ zip is vs) (Map.fromList $ zip ks is)+++class BinaryWitness a where+ putWitness :: Witness -> a -> Put+ getWitness :: Witness -> Get a++instance BinaryWitness Value where+ putWitness ws (Value x) = do+ let msg = "Internal error, could not find witness type for " ++ show (typeOf x)+ put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws)+ put x++ getWitness ws = do+ h <- get+ case Map.lookup h $ witnessIn ws of+ Nothing -> error $+ "Failed to find a type " ++ (typeNames ws !! fromIntegral h) ++ " which is stored in the database.\n" +++ "The most likely cause is that your build tool has changed significantly."+ Just (Value t) -> do+ x <- get+ return $ Value $ x `asTypeOf` t
+ Examples/Tar/Main.hs view
@@ -0,0 +1,13 @@++module Examples.Tar.Main(main) where++import Development.Shake+++main :: IO ()+main = shake shakeOptions{shakeFiles="output/tar", shakeVerbosity=2} $ do+ want ["output/tar/result.tar"]+ "output/tar/result.tar" *> \out -> do+ contents <- readFileLines "Examples/Tar/list.txt"+ need contents+ system_ $ ["tar","-cf",out] ++ contents
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2007.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,19 @@++module Main where++import System.Directory+import System.Environment++import qualified Examples.Tar.Main as Tar+++main :: IO ()+main = do+ xs <- getArgs+ case xs of+ "clean":_ -> error "todo: clean"+ "tar":xs -> mkdir "output/tar" >> withArgs xs Tar.main+ _ -> error "Enter a command to continue"+++mkdir = createDirectoryIfMissing True
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ shake.cabal view
@@ -0,0 +1,62 @@+cabal-version: >= 1.6+build-type: Simple+name: shake+version: 0.0+license: BSD3+license-file: LICENSE+category: Development+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2011+synopsis: Build system creator+description:+ Write build systems. NOT READY FOR USE YET. DO NOT USE THIS PACKAGE.+homepage: http://community.haskell.org/~ndm/shake/+stability: Beta++source-repository head+ type: darcs+ location: http://community.haskell.org/~ndm/darcs/shake/++flag testprog+ default: True+ description: Build the test program++library+ build-depends:+ base == 4.*,+ old-time,+ directory,+ hashable,+ binary,+ filepath,+ process,+ unordered-containers,+ bytestring,+ time,+ parallel-io,+ transformers == 0.2.*++ exposed-modules:+ Development.Shake+ Development.Shake.FilePath++ other-modules:+ Development.Shake.Core+ Development.Shake.Database+ Development.Shake.Derived+ Development.Shake.Directory+ Development.Shake.File+ Development.Shake.Locks+ Development.Shake.TypeHash+ Development.Shake.Value++executable shake+ main-is: Main.hs+ if flag(testprog)+ buildable: True+ else+ buildable: False++ other-modules:+ Examples.Tar.Main