shake 0.1.2 → 0.1.3
raw patch · 14 files changed
+241/−73 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Development.Shake: currentStack :: Action [Key]
Files
- Development/Shake.hs +1/−1
- Development/Shake/Core.hs +46/−20
- Development/Shake/Database.hs +10/−5
- Development/Shake/Derived.hs +2/−3
- Development/Shake/Directory.hs +2/−2
- Development/Shake/File.hs +21/−8
- Development/Shake/Locks.hs +2/−0
- Examples/Self/Main.hs +21/−22
- Examples/Tar/Main.hs +4/−3
- Examples/Test/Basic1.hs +24/−0
- Examples/Test/Directory.hs +37/−0
- Examples/Util.hs +46/−0
- Main.hs +20/−7
- shake.cabal +5/−2
Development/Shake.hs view
@@ -9,7 +9,7 @@ -- --main = 'shake' 'shakeOptions' $ do -- 'want' [\"result.tar\"]--- \"*.tar\" *> \out -> do+-- \"*.tar\" *> \\out -> do -- contents <- 'readFileLines' $ replaceExtension out \"txt\" -- 'need' contents -- 'system'' \"tar\" $ [\"-cf\",out] ++ contents
Development/Shake/Core.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE RecordWildCards, ExistentialQuantification, FunctionalDependencies, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} module Development.Shake.Core( ShakeOptions(..), shakeOptions, run, Rule(..), Rules, defaultRule, rule, action,- Action, apply, apply1, traced, currentRule,+ Action, apply, apply1, traced, currentStack, currentRule, putLoud, putNormal, putQuiet ) where +import Prelude hiding (catch) import Control.Concurrent.ParallelIO.Local+import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State@@ -32,17 +35,30 @@ -- | Options to control 'shake'. data ShakeOptions = ShakeOptions- {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.@).+ {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.shake@). ,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. }+ deriving (Show, Eq, Ord, Read) -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions "." 1 1 1+shakeOptions = ShakeOptions ".shake" 1 1 1 +data ShakeException = ShakeException [Key] SomeException+ deriving Typeable++instance Exception ShakeException++instance Show ShakeException where+ show (ShakeException stack inner) = unlines $+ "Error when running Shake build system:" :+ map (("* " ++) . show) stack +++ [show inner]++ --------------------------------------------------------------------- -- RULES @@ -146,9 +162,15 @@ 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 (runAction s0) (actions rules)+ parallel_ pool $ map (wrapStack [] . runAction s0) (actions rules) +wrapStack :: [Key] -> IO a -> IO a+wrapStack stk act = catch act $ \(SomeException e) -> case cast e of+ Just s@ShakeException{} -> throw s+ Nothing -> throw $ ShakeException stk $ SomeException e++ registerWitnesses :: Rules () -> IO () registerWitnesses Rules{..} = forM_ rules $ \(_, ARule r) -> do@@ -209,18 +231,18 @@ 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))+ error $ "Invalid rules, recursion detected when trying to build: " ++ show (head bad) 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)+ 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 x = do@@ -247,12 +269,16 @@ return res +-- | 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+-- first.+currentStack :: Action [Key]+currentStack = Action $ fmap reverse $ gets stack++ -- | Get the 'Key' for the currently executing rule - usally used to improve error messages. -- Returns 'Nothing' if being run by 'action'.-currentRule :: Action (Maybe Key)-currentRule = Action $ do- s <- get- return $ listToMaybe $ stack s+currentRule = Action $ fmap listToMaybe $ gets stack putWhen :: (Int -> Bool) -> String -> Action ()
Development/Shake/Database.hs view
@@ -30,10 +30,14 @@ import Data.Maybe import Data.List import System.Directory+import System.FilePath import System.IO-import qualified Data.ByteString.Lazy.Char8 as LBS +-- we want readFile/writeFile to be byte orientated, not do windows line end conversion+import qualified Data.ByteString.Lazy as LBS (readFile,writeFile)+import qualified Data.ByteString.Lazy.Char8 as LBS hiding (readFile,writeFile) + -- 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"@@ -77,6 +81,7 @@ = Building Barrier (Maybe Info) | Built Info | Loaded Info+ deriving Show ---------------------------------------------------------------------@@ -167,8 +172,8 @@ -- such as .database, .journal, .trace openDatabase :: FilePath -> Int -> IO Database openDatabase filename version = do- let dbfile = filename ++ ".database"- jfile = filename ++ ".journal"+ let dbfile = filename <.> "database"+ jfile = filename <.> "journal" (timestamp, status) <- readDatabase dbfile version timestamp <- return $ incTime timestamp@@ -189,7 +194,7 @@ closeDatabase :: Database -> IO () closeDatabase Database{..} = do status <- readVar status- writeDatabase (filename ++ ".database") version timestamp status+ writeDatabase (filename <.> "database") version timestamp status closeJournal journal @@ -233,7 +238,7 @@ openJournal :: FilePath -> Int -> IO Journal openJournal journalFile ver = do- h <- openFile journalFile WriteMode+ h <- openBinaryFile journalFile WriteMode hSetFileSize h 0 LBS.hPut h $ LBS.pack $ journalVersion ver witness <- currentWitness
Development/Shake/Derived.hs view
@@ -20,9 +20,8 @@ let cmd = unwords $ path2 : args putLoud cmd res <- liftIO $ rawSystem path2 args- when (res /= ExitSuccess) $ do- k <- currentRule- error $ "System command failed while building " ++ show k ++ ", " ++ cmd+ when (res /= ExitSuccess) $+ error $ "System command failed:\n" ++ cmd -- | @copyFile old new@ copies the existing file from @old@ to @new@. The @old@ file is has 'need' called on it
Development/Shake/Directory.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-} module Development.Shake.Directory( doesFileExist,@@ -66,7 +66,7 @@ defaultRuleDirectory = do defaultRule $ \(Exist x) -> Just $ liftIO $ IO.doesFileExist x- defaultRule $ \x@GetDir{} -> Just $+ defaultRule $ \(x :: GetDir) -> Just $ liftIO $ getDir x
Development/Shake/File.hs view
@@ -10,7 +10,6 @@ import Data.Binary import Data.Hashable import Data.List-import Data.Maybe import Data.Typeable import System.Directory import System.Time@@ -39,17 +38,24 @@ TOD t _ <- getModificationTime x return $ Just $ FileTime $ fromIntegral t +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 ++ instance Rule File FileTime where validStored (File x) t = fmap (== Just t) $ getFileTime x -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleFile :: Rules ()-defaultRuleFile = defaultRule $ \(File x) -> Just $ do- res <- liftIO $ getFileTime x- let msg = "Error, file does not exist and no available rule: " ++ x- return $ fromMaybe (error msg) res+defaultRuleFile = defaultRule $ \(File x) -> Just $+ liftIO $ getFileTimeErr "Error, file does not exist and no rule available:" x -- | Require that the following files are built before continuing. Particularly@@ -85,9 +91,7 @@ if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x act x- res <- liftIO $ getFileTime x- let msg = "Error, rule failed to build the file: " ++ x- return $ fromMaybe (error msg) res+ liftIO $ getFileTimeErr "Error, rule failed to build the file:" x -- | Define a set of patterns, and if any of them match, run the associate rule. See '*>'.@@ -104,6 +108,8 @@ -- -- To define a build system for multiple compiled languages, we recommend using @.asm.o@, -- @.cpp.o@, @.hs.o@, to indicate which language produces an object file.+-- I.e., the file @foo.cpp@ produces object file @foo.cpp.o@.+-- (*>) :: FilePattern -> (FilePath -> Action ()) -> Rules () (*>) test act = (test ?==) ?> act @@ -118,7 +124,14 @@ -- -- > "//*.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
Development/Shake/Locks.hs view
@@ -14,6 +14,7 @@ -- | Like an MVar, but must always be full newtype Var a = Var (MVar a)+instance Show (Var a) where show _ = "Var" newVar :: a -> IO (Var a) newVar = fmap Var . newMVar@@ -34,6 +35,7 @@ -- 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 ()]))+instance Show Barrier where show _ = "Barrier" newBarrier :: IO Barrier newBarrier = fmap Barrier $ newIORef $ Just []
Examples/Self/Main.hs view
@@ -3,6 +3,7 @@ import Development.Shake import Development.Shake.FilePath+import Examples.Util import Control.Monad import Data.Char@@ -10,41 +11,39 @@ main :: IO ()-main = shake shakeOptions{shakeFiles="output/self", shakeVerbosity=2, shakeParallel=1} $ do+main = shaken noTest $ \obj -> do let pkgs = "transformers binary unordered-containers parallel-io filepath directory process" flags = map ("-package=" ++) $ words pkgs - let out x = "output/self/" ++ x- unout x = dropDirectory1 $ dropDirectory1 x- moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext- want [out "Main.exe"]+ let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext+ want [obj "Main.exe"] - out "/*.exe" *> \res -> do- src <- readFileLines $ replaceExtension res "deps"- let os = map (out . moduleToFile "o") $ "Main":src+ obj "/*.exe" *> \out -> do+ src <- readFileLines $ replaceExtension out "deps"+ let os = map (obj . moduleToFile "o") $ "Main":src need os- system' "ghc" $ ["-o",res] ++ os ++ flags+ system' "ghc" $ ["-o",out] ++ os ++ flags - out "/*.deps" *> \res -> do- dep <- readFileLines $ replaceExtension res "dep"- let xs = map (out . moduleToFile "deps") dep+ obj "/*.deps" *> \out -> do+ dep <- readFileLines $ replaceExtension out "dep"+ let xs = map (obj . moduleToFile "deps") dep need xs ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs- writeFileLines res ds+ writeFileLines out ds - out "/*.dep" *> \res -> do- src <- readFile' $ unout $ replaceExtension res "hs"+ obj "/*.dep" *> \out -> do+ src <- readFile' $ unobj $ replaceExtension out "hs" let xs = hsImports src xs <- filterM (doesFileExist . moduleToFile "hs") xs- writeFileLines res xs+ writeFileLines out xs - out "/*.hi" *> \res -> do- need [replaceExtension res "o"]+ obj "/*.hi" *> \out -> do+ need [replaceExtension out "o"] - out "/*.o" *> \res -> do- dep <- readFileLines $ replaceExtension res "dep"- let hs = unout $ replaceExtension res "hs"- need $ hs : map (out . moduleToFile "hi") dep+ obj "/*.o" *> \out -> do+ dep <- readFileLines $ replaceExtension out "dep"+ let hs = unobj $ replaceExtension out "hs"+ need $ hs : map (obj . moduleToFile "hi") dep system' "ghc" $ ["-c",hs,"-odir=output/self","-hidir=output/self","-i=output/self"] ++ flags
Examples/Tar/Main.hs view
@@ -2,12 +2,13 @@ module Examples.Tar.Main(main) where import Development.Shake+import Examples.Util main :: IO ()-main = shake shakeOptions{shakeFiles="output/tar", shakeVerbosity=2} $ do- want ["output/tar/result.tar"]- "output/tar/result.tar" *> \out -> do+main = shaken noTest $ \obj -> do+ want [obj "result.tar"]+ obj "result.tar" *> \out -> do contents <- readFileLines "Examples/Tar/list.txt" need contents system' "tar" $ ["-cf",out] ++ contents
+ Examples/Test/Basic1.hs view
@@ -0,0 +1,24 @@++module Examples.Test.Basic1(main) where++import Development.Shake+import Examples.Util++main = shaken test $ \obj -> do+ want [obj "AB.txt"]+ 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+++test build obj = do+ writeFile (obj "A.txt") "AAA"+ writeFile (obj "B.txt") "BBB"+ build []+ assertContents (obj "AB.txt") "AAABBB"+ sleep 1+ appendFile (obj "A.txt") "aaa"+ build []+ assertContents (obj "AB.txt") "AAAaaaBBB"
+ Examples/Test/Directory.hs view
@@ -0,0 +1,37 @@++module Examples.Test.Directory(main) where++import Development.Shake+import Examples.Util+import System.Directory(createDirectory)+++main = shaken test $ \obj -> do+ want $ map obj ["files.lst","dirs.lst","exist.lst"]+ obj "files.lst" *> \out -> do+ x <- getDirectoryFiles (obj "") "*.txt"+ writeFileLines out x+ obj "dirs.lst" *> \out -> do+ x <- getDirectoryDirs (obj "")+ writeFileLines out x+ obj "exist.lst" *> \out -> do+ xs <- readFileLines $ obj "files.lst"+ ys <- mapM (doesFileExist . obj) $ xs ++ map reverse xs+ writeFileLines out $ map show ys+++test build obj = do+ build ["clean"]+ build []+ assertContents (obj "files.lst") $ unlines []+ assertContents (obj "dirs.lst") $ unlines []+ assertContents (obj "exist.lst") $ unlines []++ writeFile (obj "A.txt") ""+ writeFile (obj "B.txt") ""+ createDirectory (obj "Foo.txt")+ sleep 1+ build []+ assertContents (obj "files.lst") $ unlines ["A.txt","B.txt"]+ assertContents (obj "dirs.lst") $ unlines ["Foo.txt"]+ assertContents (obj "exist.lst") $ unlines ["True","True","False","False"]
+ Examples/Util.hs view
@@ -0,0 +1,46 @@++module Examples.Util where++import Development.Shake+import Development.Shake.FilePath++import Control.Concurrent(threadDelay)+import Control.Monad+import System.Directory+import System.Environment+++shaken+ :: (([String] -> IO ()) -> (String -> String) -> IO ())+ -> ((String -> String) -> Rules ())+ -> IO ()+shaken test rules = do+ name:args <- getArgs+ let out = "output/" ++ name ++ "/"+ createDirectoryIfMissing True out+ case args of+ "test":_ -> do+ putStrLn $ "## TESTING " ++ name+ test (\args -> withArgs (name:args) $ shaken test rules) (out++)+ "clean":_ -> removeDirectoryRecursive out+ _ -> withArgs args $ shake shakeOptions{shakeFiles=out} $ rules (out++)+++unobj :: FilePath -> FilePath+unobj = dropDirectory1 . dropDirectory1+++assertContents :: FilePath -> String -> IO ()+assertContents file want = do+ got <- readFile file+ when (want /= got) $ error $ "File contents are wrong: " ++ file ++ show (want,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
@@ -1,21 +1,34 @@ module Main where -import System.Directory+import Data.Maybe import System.Environment import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self+import qualified Examples.Test.Basic1 as Basic1+import qualified Examples.Test.Directory as Directory +fakes = ["clean" * clean, "test" * test]+ where (*) = (,)++mains = ["tar" * Tar.main, "self" * Self.main+ ,"basic1" * Basic1.main, "directory" * Directory.main]+ where (*) = (,)++ main :: IO () main = do xs <- getArgs- case xs of- "clean":_ -> error "todo: clean"- "tar":xs -> mkdir "output/tar" >> withArgs xs Tar.main- "self":xs -> mkdir "output/self" >> withArgs xs Self.main- _ -> error "Enter a command to continue"+ case flip lookup (fakes ++ mains) =<< listToMaybe xs of+ Nothing -> error $ "Enter one of the examples: " ++ unwords (map fst $ fakes ++ mains)+ Just main -> main -mkdir = createDirectoryIfMissing True+clean :: IO ()+clean = sequence_ [withArgs [name,"clean"] main | (name,main) <- mains]+++test :: IO ()+test = sequence_ [withArgs [name,"test"] main | (name,main) <- mains]
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake-version: 0.1.2+version: 0.1.3 license: BSD3 license-file: LICENSE category: Development@@ -87,5 +87,8 @@ buildable: False other-modules:- Examples.Tar.Main+ Examples.Util Examples.Self.Main+ Examples.Test.Basic1+ Examples.Test.Directory+ Examples.Tar.Main