cake 0.4.0.0 → 0.4.2.0
raw patch · 3 files changed
+47/−37 lines, 3 filesdep ~bytestringdep ~containersdep ~directory
Dependency ranges changed: bytestring, containers, directory
Files
- Cake/Core.hs +37/−30
- Cake/Rules.hs +5/−2
- cake.cabal +5/−5
Cake/Core.hs view
@@ -20,7 +20,7 @@ distill, fileStamp, cut,- shielded,+ -- shielded, Question(..), Answer(..), Failure(..),@@ -30,7 +30,6 @@ ) where import Data.Digest.Pure.MD5--- import Data.Digest.OpenSSL.MD5 -- "nano-md5" -- md5sum import qualified Data.ByteString.Lazy as B import System.Directory@@ -59,8 +58,18 @@ deriving (Eq, Ord) $( derive makeBinary ''Question ) +data Failure = CakeError String | Panic | ProcessError ExitCode+ deriving (Eq)+instance Show Failure where+ show (CakeError x) = x+ show (ProcessError code) = "Process returned exit code " ++ show code+ show (Panic) = "PANIC"+$( derive makeBinary ''ExitCode ) +$( derive makeBinary ''Failure ) + data Answer = Stamp (Maybe MD5Digest) | Text [String]+ | Failed Failure deriving (Eq, Show) $( derive makeBinary ''Answer ) @@ -78,7 +87,6 @@ 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 Failure = CakeError String | Panic | ProcessError ExitCode data Context = Context {ctxHandle :: Handle, ctxRule :: Rule, ctxDB :: DB, ctxProducing :: [Question]} newtype Act a = Act (ErrorT Failure (RWST Context Written State IO) a) deriving (Functor, Applicative, Monad, MonadIO, MonadState State, MonadWriter Written, MonadReader Context, MonadError Failure)@@ -90,11 +98,6 @@ noMsg = Panic strMsg = CakeError -instance Show Failure where- show (CakeError x) = x- show (ProcessError code) = "Process returned exit code " ++ show code- show (Panic) = "PANIC"- instance Applicative P where (<*>) = ap pure = return@@ -119,7 +122,8 @@ oldDB <- if e then decodeFile databaseFile else return $ M.empty- newDB <- runAct rule oldDB action+ newAnswers <- runAct rule oldDB action+ let newDB = newAnswers <> oldDB -- new answers overwrite old ones putStrLn $ "Database is:" forM_ (M.assocs newDB) $ \(k,v) -> putStrLn $ (show k) ++ " => " ++ (show v)@@ -131,30 +135,33 @@ (ps,_) <- RWS.get return $ f `S.member` ps +modCx q (Context {..}) = Context {ctxProducing = q:ctxProducing,..} + -- | Answer a question using the action given.--- The action should be independent of the context.+-- The action must be independent of the context. distill :: Question -> Act Answer -> Act Answer-distill q act = - local (modCx q) $ do- debug $ "Starting to answer"- db <- ctxDB <$> ask- let a0 = M.lookup q db- a1 <- shielded act- tell (Dual $ M.singleton q a1)- when (Just a1 /= a0) $ do- clobber- debug $ "Question has not the same answer"- return a1--modCx q (Context {..}) = Context {ctxProducing = q:ctxProducing,..} +distill q act = local (modCx q) $ do+ debug $ "Starting to answer"+ db <- ctxDB <$> ask+ a1 <- refresh q act+ when (Just a1 /= M.lookup q db) $ do+ clobber+ debug $ "Question has not the same answer"+ return a1 +-- | Answer a question using the action given. The action must be+-- independent of the context. The result is not compared to the+-- previous run, so it is the caller responsibility that the new+-- answer is properly taken into account. refresh :: Question -> Act Answer -> Act Answer-refresh q act = local (modCx q) $ do- debug $ "Overwriting"- a <- shielded act- tell (Dual $ M.singleton q a)- return a- +refresh q act = + do a <- shielded act+ tell (Dual $ M.singleton q a)+ return a+ `catchError` \ e -> do -- on error+ tell (Dual $ M.singleton q $ Failed e) -- Answering the question failed...+ throwError e -- and questions depending on it will also fail+ -- | Produce a file, using the given action. -- The action should be independent of the context. produce :: FilePath -> Act () -> Act ()@@ -187,7 +194,7 @@ -- | Mark that a file is used. Do not chase dependencies on this file--- though.+-- though. (To be used eg. if a command uses an optional file). use f = distill (FileContents f) (fileStamp f)
Cake/Rules.hs view
@@ -50,7 +50,10 @@ pandoc inp typ options = produce out $ do need inp cut $ system $ ["pandoc",inp,"-t",typ,"-o",out] ++ options- where out = replaceExtension inp typ+ where out = replaceExtension inp ext+ ext = case typ of + "latex" -> "tex"+ _ -> typ graphviz program inp typ options = produce out $ needing [inp] $ do system $ [program, "-T"++typ, "-o"++out, inp] ++ options@@ -79,7 +82,7 @@ tex_markdown_standalone = simple ".tex" ".markdown" $ \o i -> - pandoc i o ["--standalone"]+ pandoc i "latex" ["--standalone"] {- html_markdown_standalone = simple ".html" ".markdown" $ \o i -> system ["pandoc","--tab-stop=2","--standalone","-f","markdown","-t","latex",
cake.cabal view
@@ -1,5 +1,5 @@ name: cake-version: 0.4.0.0+version: 0.4.2.0 category: Development synopsis: A build-system library and driver description:@@ -21,9 +21,9 @@ build-depends: filepath==1.3.* build-depends: process==1.1.* build-depends: binary==0.5.*- build-depends: containers==0.4.*- build-depends: directory==1.1.*- build-depends: bytestring==0.9.*+ build-depends: containers==0.5.*+ build-depends: directory==1.2.*+ build-depends: bytestring==0.10.* build-depends: pureMD5==2.1.* build-depends: split==0.1.* @@ -37,7 +37,7 @@ build-depends: regex-tdfa==1.1.* build-depends: array==0.4.* build-depends: filepath==1.3.* - build-depends: directory==1.1.*+ build-depends: directory==1.2.* main-is: Main.hs