diff --git a/Development/Shake.hs b/Development/Shake.hs new file mode 100644 --- /dev/null +++ b/Development/Shake.hs @@ -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 () diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Core.hs @@ -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) diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Database.hs @@ -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 diff --git a/Development/Shake/Derived.hs b/Development/Shake/Derived.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Derived.hs @@ -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_ diff --git a/Development/Shake/Directory.hs b/Development/Shake/Directory.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Directory.hs @@ -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 diff --git a/Development/Shake/File.hs b/Development/Shake/File.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/File.hs @@ -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 diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/FilePath.hs @@ -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 diff --git a/Development/Shake/Locks.hs b/Development/Shake/Locks.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Locks.hs @@ -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 diff --git a/Development/Shake/TypeHash.hs b/Development/Shake/TypeHash.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/TypeHash.hs @@ -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 diff --git a/Development/Shake/Value.hs b/Development/Shake/Value.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Value.hs @@ -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 diff --git a/Examples/Tar/Main.hs b/Examples/Tar/Main.hs new file mode 100644 --- /dev/null +++ b/Examples/Tar/Main.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shake.cabal b/shake.cabal new file mode 100644 --- /dev/null +++ b/shake.cabal @@ -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 +maintainer: Neil Mitchell +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