cake 0.0.1 → 0.1.0
raw patch · 6 files changed
+333/−118 lines, 6 filesdep +arraydep +cmdargsdep +derivedep −groomnew-component:exe:cake
Dependencies added: array, cmdargs, derive, regex-tdfa, split
Dependencies removed: groom
Files
- Cake.hs +3/−1
- Cake/Core.hs +129/−68
- Cake/Process.hs +39/−0
- Cake/Rules.hs +96/−43
- Main.hs +45/−0
- cake.cabal +21/−6
Cake.hs view
@@ -1,8 +1,10 @@ module Cake (module Cake.Core, - module Cake.Rules) where+ module Cake.Rules,+ module Cake.Process) where import Cake.Core import Cake.Rules+import Cake.Process
Cake/Core.hs view
@@ -1,15 +1,29 @@-module Cake.Core (Pattern, (==>),- cake,- query,- cut,- promise,- need, - debug,- module Control.Applicative,- Act, - ) where+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, TemplateHaskell, RecordWildCards #-} -import "pureMD5" Data.Digest.Pure.MD5+module Cake.Core (+ -- * Patterns and rules.+ Rule,+ P, (==>),+ + -- * High-level interface+ Act, + cake,+ need, + -- * Mid-level interface+ produce,+ use,+ -- * Low-level interface+ shielded,+ debug,+ query,+ cut,+ Question(..),+ Answer(..),+ -- * Re-exports+ module Control.Applicative,+ ) where++import Data.Digest.Pure.MD5 -- import Data.Digest.OpenSSL.MD5 -- "nano-md5" -- md5sum import qualified Data.ByteString.Lazy as B@@ -17,15 +31,47 @@ import System.FilePath import Control.Applicative import Control.Monad (when)-import Control.Monad.RWS+import Control.Monad.RWS hiding (put,get)+import qualified Control.Monad.RWS as RWS import qualified Parsek import Parsek (completeResults, parse, Parser) import qualified Data.Map as M+import qualified Data.Set as S import Data.Binary hiding (put,get)-import Text.Groom-import qualified System.Process as P import System.Exit+import Control.Arrow (second,first) +import Data.DeriveTH+import Data.Binary++data Question = Stamp FilePath + | Listing FilePath String+-- | Option [String]+ deriving (Eq, Ord, Show)+$( derive makeBinary ''Question ) + +data Answer = Stamp' (Maybe MD5Digest) + | Text [String]+ deriving (Eq, Show)+$( derive makeBinary ''Answer ) + +type DB = M.Map Question Answer+type Produced = S.Set FilePath ++type P = Parser Char++-- | Rules map names of files to actions building them.+type Rule = P (Act ()) +type State = (Produced,Status)+type Written = Dual DB -- take the dual so the writer overwrites old entries in the DB.+data Context = Context {ctxRule :: Rule, ctxDB :: DB, ctxProducing :: [FilePath]}+newtype Act a = Act (RWST Context Written State IO a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadState State, MonadWriter Written, MonadReader Context)+-- Take the dual here so that new info overwrites old.++data Status = Clean | Dirty + deriving Eq+ instance Applicative P where (<*>) = ap pure = return@@ -34,65 +80,74 @@ (<|>) = (Parsek.<|>) empty = Parsek.pzero --type Pattern = P String--type P = Parser Char-type Rule = P (Act ())--data Status = Clean | Dirty - deriving Eq- -(==>) :: Pattern -> (String -> Act a) -> Rule+(==>) :: P x -> (x -> Act a) -> Rule p ==> a = (\s -> do a s;return ()) <$> p -newtype LocalR = LocalR {fromLocalR :: P (Act ())} --cakeFile = ".cake"+databaseFile = ".cake" -cake :: [FilePath] -> Rule -> IO ()-cake targets rule = do- e <- doesFileExist cakeFile +-- | Run an action in the context of a set of rules.+cake :: Rule -> Act () -> IO ()+cake rule action = do+ e <- doesFileExist databaseFile oldDB <- if e - then decodeFile cakeFile+ then decodeFile databaseFile else return $ M.empty- newDB <- runAct rule oldDB $ mapM_ need targets+ newDB <- runAct rule oldDB action putStrLn $ "Database is:"- putStrLn (groom newDB)- encodeFile cakeFile newDB+ forM_ (M.assocs newDB) $ \(k,v) ->+ putStrLn $ (show k) ++ " => " ++ (show v)+ encodeFile databaseFile newDB -newtype Question = Stamp FilePath deriving (Eq, Ord, Binary, Show)+produced :: FilePath -> Act Bool+produced f = do + (ps,_) <- RWS.get+ return $ f `S.member` ps -newtype Answer = Stamp' (Maybe MD5Digest) deriving (Eq, Binary, Show)- -type DB = M.Map Question Answer- -promise :: FilePath -> Act () -> Act () -promise f a = shielded $ do- e0 <- liftIO $ doesFileExist f- when (not e0) $ put Dirty -- force rebuilding if the target is missing.- a- e <- liftIO $ doesFileExist f- when (not e) $ fail $ "Action failed to create " ++ f+produce :: FilePath -> Act () -> Act ()+produce f a = local modCx $ do+ p <- produced f+ -- Do nothing if the file is already produced.+ when (not p) $ do debug $ "starting production"+ shielded $ do e <- liftIO $ doesFileExist f+ when (not e) clobber + a+ -- when (not e) $ fail $ "Action failed to create " ++ f+ + use f -- If the new file has changed, then set dirty flag. + modify $ first $ S.insert f -- remember that the file has been produced already+ where modCx (Context {..}) = Context {ctxProducing = f:ctxProducing,..} --- Assume that the context is clean; that is, the construction of the+-- | Mark that a file is used. No dependency is created on this file+-- though.+use f = query (Stamp f)+ +-- | Assume that the context is clean; that is, the construction of the -- argument actually does not depend on the previous questions asked. -- NOTE: This can be used only when the purpose of the argument (why--- we call it) is known; and then the dirty flag must be set if the--- produced object is not present.-shielded = withRWST (\r _ -> (r,Clean))+-- we call it) is known -- for example we already have determined that+-- another goal depends on what we're going to perform. The dirty flag+-- must be set independently in the context if the produced object is+-- not present.+shielded :: Act () -> Act ()+shielded a = do + (ps,s) <- RWS.get+ RWS.put (ps,Clean)+ a+ (ps',_) <- RWS.get+ RWS.put (ps',s) -runAct r db act = do - (_a,db) <- evalRWST act (LocalR r,db) Clean +runAct :: Rule -> DB -> Act () -> IO DB+runAct r db (Act act) = do + (_a,Dual db) <- evalRWST act (Context r db []) (S.empty,Clean) return db findRule :: FilePath -> Act (Maybe (Act ())) findRule f = do- (LocalR r,_) <- ask+ r <- ctxRule <$> ask let rs = parse r completeResults f case rs of Right [x] -> return (Just x)@@ -101,16 +156,18 @@ debug $ "No rule for file: " ++ f -- debug $ "Parser says: " ++ show e return Nothing- - - --- runAct :: Act () -> RWST (Rule,DB) DB Status IO-type Act = RWST (LocalR,DB) DB Status IO-runAct :: Rule -> DB -> Act () -> IO DB- -debug x = liftIO $ putStrLn $ "Info: " ++ x + + +debug x = do + ps <- ctxProducing <$> ask+ liftIO $ putStrLn $ "cake: " ++ concat (map (++": ") $ reverse ps) ++ x runQuery :: Question -> IO Answer +runQuery (Listing directory extension) = do+ files <- filter (filt . takeExtension) <$> getDirectoryContents directory+ return $ Text (map (directory </>) files)+ where filt = if null extension then const True else (== '.':extension)+ runQuery (Stamp f) = do e <- doesFileExist f Stamp' <$> if e @@ -120,20 +177,24 @@ query :: Question -> Act Answer query q = do a <- liftIO $ runQuery q- tell (M.singleton q a)- (_,db) <- ask+ tell (Dual $ M.singleton q a)+ db <- ctxDB <$> ask let a0 = M.lookup q db when (a0 /= Just a) $ do debug $ "Question has not the same answer: " ++ show q- put Dirty+ clobber return $ a + +clobber = RWS.modify $ second $ const Dirty+ cut x = do- d <- get- case d of+ (_,s) <- RWS.get+ case s of Clean -> debug $ "Clean state; skipping." Dirty -> x +-- | Try to build a file using known rules; then mark it as used. need :: FilePath -> Act () need f = do debug $ "Need: " ++ f@@ -142,7 +203,7 @@ Nothing -> do e <- liftIO $ doesFileExist f when (not e) $ fail $ "No rule to create " ++ f+ use f debug $ "File exists: " ++ f- Just a -> promise f a- query (Stamp f)+ Just a -> a return ()
+ Cake/Process.hs view
@@ -0,0 +1,39 @@+module Cake.Process (processIO, Cake.Process.system) where++import Cake.Core+import System.IO+import Control.Applicative+import Control.Monad.Trans+import System.Process as P+import Data.List+import System.Exit+import Control.Monad++quote :: String -> String+quote = show+++maybeM :: Applicative m => (a -> m Handle) -> Maybe a -> m StdStream+maybeM f Nothing = pure Inherit+maybeM f (Just x) = UseHandle <$> f x++processIO' :: FilePath -> [String] -> Maybe FilePath -> Maybe FilePath -> Act ExitCode+processIO' cmd args inp out = do+ debug $ "running: "++ cmd ++ " " ++ intercalate " " args+ liftIO $ do+ o <- maybeM (flip openFile WriteMode) out+ i <- maybeM (flip openFile ReadMode) inp+ (_,_,_,p) <- createProcess $ (shell (intercalate " " $ map quote (cmd:args))) {std_in = i, std_out = o}+ waitForProcess p+ + +system' :: [String] -> Act ExitCode+system' (x:xs) = processIO' x xs Nothing Nothing++succeed :: Act ExitCode -> Act ()+succeed act = do+ code <- act+ when (code /= ExitSuccess) $ fail "Command returned non-zero exitcode."++system xs = succeed $ system' xs+processIO c a i o = succeed $ processIO' c a i o
Cake/Rules.hs view
@@ -1,53 +1,45 @@ module Cake.Rules where import Cake.Core-import qualified Parsek+import Cake.Process import System.Directory import System.FilePath import Control.Applicative import Control.Monad (when)-import Control.Monad.RWS+import Control.Monad.RWS (liftIO) import qualified Parsek import Parsek (completeResults, parse, Parser)-import qualified Data.Map as M-import Data.Binary hiding (put,get)-import Text.Groom-import qualified System.Process as P-import System.Exit import Data.List----- Helpers-quote :: String -> String-quote = show+import Data.List.Split +------------------------------------------------------ -- Patterns-extension :: String -> Pattern-extension s = Parsek.many Parsek.anyChar <* Parsek.string s+extension :: String -> P (String,String)+extension s = do+ base <- Parsek.many Parsek.anyChar+ Parsek.string s+ return (base++s,base) +anyExtension :: [String] -> P (String,String)+anyExtension ss = foldr (<|>) empty (map extension ss)++--------------------------------------------------------- -- Actions+list :: FilePath -> String -> Act [String]+list dir ext = do+ Text xs <- query (Listing dir ext)+ return xs+ copy :: FilePath -> FilePath -> Act()-copy from to = promise to $ needing [from] $ do+copy from to = produce to $ needing [from] $ do mkdir $ takeDirectory to liftIO $ copyFile from to -system' :: [String] -> Act ExitCode-system' xs = do - debug $ "Running: " ++ (intercalate " " xs)- liftIO $ P.system (intercalate " " $ map quote xs)--succeed :: Act ExitCode -> Act ()-succeed act = do- code <- act- when (code /= ExitSuccess) $ fail "Command returned non-zero exitcode."- mkdir :: FilePath -> Act () mkdir d = liftIO $ createDirectoryIfMissing True d -system xs = succeed $ system' xs- touch :: FilePath -> Act ()-touch x = do+touch x = produce x $ do system ["touch",x] readFile :: FilePath -> Act String@@ -55,7 +47,19 @@ need x liftIO $ Prelude.readFile x +_pdflatex x = system ["pdflatex",x]+ +_bibtex x = system ["bibtex",x] +pandoc inp typ options = produce out $ do + need inp+ cut $ system $ ["pandoc",inp,"-t",typ,"-o",out] ++ options+ where out = replaceExtension inp typ+ +graphviz program inp typ options = produce out $ needing [inp] $ do+ system $ [program, "-T"++typ, "-o"++out, inp] ++ options+ where out = replaceExtension inp typ+ {- mpostDeriv = extension "-delayed.mp" ==> \s -> do let input = s ++ ".mp"@@ -70,29 +74,78 @@ mapM_ need xs cut act +-------------------------------------------------------------- -- Rules -simple outExt inExt f = extension outExt ==> \s -> do- let input = s ++ inExt- output = s ++ outExt- needing [input] $ f output input+simple outExt inExt f = extension outExt ==> \(output,base) ->+ let input = base ++ inExt + in produce output $ needing [input] $ f output input tex_markdown_standalone = simple ".tex" ".markdown" $ \o i -> + pandoc i o ["--standalone"]+{-+html_markdown_standalone = simple ".html" ".markdown" $ \o i -> system ["pandoc","--tab-stop=2","--standalone","-f","markdown","-t","latex", "-o", o, i]+ -} +{-+tex_lhs = extension ".tex" $ \c -> do+ + -- chase includes+ -}++ pdf_tex = simple ".pdf" ".tex" $ \o i -> system ["latexmk","-pdf",i] -{--pdf_tex2 = extension ".pdf" $ \c -> do- let input = extension ".tex"- ls <- filter ("\\bibliography" `isPrefixOf`) lines <$> readFile input- cut $ do- case ls of- [] -> return ()- (l:_) -> do let l' = reverse . dropWhile (== '}') . dropWhile . reverse . dropWhile (== '{') $ l- bibs = spli--}-allRules = tex_markdown_standalone <|> pdf_tex+pdflatexBibtex c = do+ let input = c ++ ".tex"+ aux1 = c ++ ".aux1"+ aux = c ++ ".aux"+ pdf = c ++ ".pdf"+ produce pdf $ do + produce aux1 $ needing [input] $ do _pdflatex c+ liftIO $ copyFile aux aux1+ + ls <- map (drop 14) . filter ("\\bibliography{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input+ let bibs = map (++".bib") $ case ls of+ [] -> []+ (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l+ + produce aux $ do+ produce (c ++ ".bbl") $ do+ -- Note that this does not depend on the actual tex file; only the list of bibs. (aux1)+ mapM_ need bibs+ use aux1+ cut $ _bibtex c+ cut $ _pdflatex c+ + cut $ _pdflatex c++pdf_tex_bibtex = extension ".pdf" ==> \(_,c) -> pdflatexBibtex c+++pdf_tex_biblatex = anyExtension [".pdf",".aux"] ==> \(_,c) -> do + let input = c ++ ".tex"+ aux = c ++ ".aux"+ pdf = c ++ ".pdf"+ produce pdf $ do + produce aux $ needing [input] $ _pdflatex c+ + ls <- map (drop 14) . filter ("\\bibliography{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input+ let bibs = map (++".bib") $ case ls of+ [] -> []+ (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l+ + produce (c ++ ".bbl") $ do+ -- Note that this does not depend on the actual tex file; only the list of bibs.+ mapM_ need bibs+ use aux+ cut $ _bibtex c++ cut $ _pdflatex c+ ++allRules = tex_markdown_standalone <|> pdf_tex_biblatex
+ Main.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+import System.Process+import System.Console.CmdArgs.Implicit+import Data.List (intercalate)+-- import Paths_cake+import Data.Version (Version(..))+import Text.Regex.TDFA+import Control.Applicative+import Data.Array++data Args = Args {targets' :: [String],+ rules :: String,+ cakefile :: String+ } + deriving (Show, Data, Typeable)+++opts = cmdArgsMode $ Args { + rules = "rules" &= help "rules to use" &= typ "Rule",+ cakefile = "Cakefile.hs" &= name "f" &= help "cakefile to use" &= typFile,+ targets' = [] &= args &= typ "Act ()"+ } &= program "cake" +-- &= summary ("cake " ++ intercalate "." (map show (versionBranch version)))++paren x = "(" ++ x ++ ")" ++regex :: Regex+regex = makeRegex "import[ \\t]+(qualified[ \\t]+)?([^ \\t]*)[ \\t]*--[ \\t]*FROM[ \\t]*([^ \\t]+)[ \\t]*"++define (modul,dir) = "-DROOT_" ++ modul ++ "=" ++ show (show dir)++main = do + Args {..} <- cmdArgsRun opts+ cf <- readFile cakefile+ + let + targets = (if null targets' then ("action":) else id) targets'+ imports = [(fst (arr!2), fst (arr!3)) | l <- lines cf, Just (_,arr,_) <- [matchOnceText regex l]] + defines = intercalate " " $ map define imports+ searchdir = "-i" ++ intercalate ":" (map snd imports)+ expr = "cake " ++ paren rules ++ paren (intercalate " >> " $ map paren targets)+ command = "ghc -XCPP " ++ searchdir ++ " " ++ defines ++ " -e " ++ show expr ++ " " ++ cakefile + putStrLn $ "cake: running " ++ command+ system command+ return ()
cake.cabal view
@@ -1,7 +1,7 @@ name: cake-version: 0.0.1+version: 0.1.0 category: Development-synopsis: A build-system library+synopsis: A build-system library and driver description: Soon to appear. license: GPL@@ -13,16 +13,31 @@ build-type: Simple library- extensions: PackageImports, GeneralizedNewtypeDeriving, TypeSynonymInstances+ -- extensions: PackageImports, GeneralizedNewtypeDeriving, TypeSynonymInstances build-depends: base==4.*+ build-depends: derive==2.5.* build-depends: mtl==2.0.* build-depends: filepath==1.1.* build-depends: process==1.0.*- build-depends: groom==0.1.* build-depends: binary==0.5.* build-depends: containers==0.3.* build-depends: directory==1.0.*- build-depends: Encode==1.3.*+ build-depends: Encode==1.3.* + -- Encode contains a copy of parsek build-depends: bytestring==0.9.* build-depends: pureMD5==2.1.*- exposed-modules: Cake, Cake.Core, Cake.Rules+ build-depends: split==0.1.*++ exposed-modules: Cake, Cake.Core, Cake.Rules, Cake.Process++executable cake+ build-depends: base==4.*+ build-depends: process==1.0.*+ build-depends: cmdargs==0.7.*+ build-depends: regex-tdfa==1.1.*+ build-depends: array==0.3.*++ main-is: Main.hs+++