diff --git a/Cake/Core.hs b/Cake/Core.hs --- a/Cake/Core.hs +++ b/Cake/Core.hs @@ -23,8 +23,10 @@ shielded, Question(..), Answer(..), + Failure(..), -- * Re-exports module Control.Applicative, + throwError, ) where import Data.Digest.Pure.MD5 @@ -37,6 +39,7 @@ import Control.Monad (when) import Control.Monad.RWS hiding (put,get) import qualified Control.Monad.RWS as RWS +import Control.Monad.Error import qualified Parsek import Parsek (completeResults, parse, Parser) import qualified Data.Map as M @@ -75,14 +78,23 @@ 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 (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. +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) data Status = Clean | Dirty deriving Eq - + +instance Error Failure where + 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 @@ -113,7 +125,7 @@ putStrLn $ (show k) ++ " => " ++ (show v) encodeFile databaseFile newDB - +-- | Was the file already produced? produced :: FilePath -> Act Bool produced f = do (ps,_) <- RWS.get @@ -122,8 +134,8 @@ -- | Answer a question using the action given. -- The action should be independent of the context. distill :: Question -> Act Answer -> Act Answer -distill q act = do - a1 <- local (modCx q) $ do +distill q act = + local (modCx q) $ do debug $ "Starting to answer" db <- ctxDB <$> ask let a0 = M.lookup q db @@ -133,8 +145,6 @@ clobber debug $ "Question has not the same answer" return a1 - debug $ "..." - return a1 modCx q (Context {..}) = Context {ctxProducing = q:ctxProducing,..} @@ -145,7 +155,7 @@ tell (Dual $ M.singleton q a) return a --- | Produce a file, using with the given action. +-- | Produce a file, using the given action. -- The action should be independent of the context. produce :: FilePath -> Act () -> Act () produce f a = do @@ -178,8 +188,7 @@ -- | Mark that a file is used. Do not chase dependencies on this file -- though. -use f = do - distill (FileContents f) (fileStamp f) +use f = distill (FileContents f) (fileStamp f) -- | File was modified by some command, but in a way that does not @@ -209,7 +218,10 @@ runAct :: Rule -> DB -> Act () -> IO DB runAct r db (Act act) = do h <- openFile logFile WriteMode - (_a,Dual db) <- evalRWST act (Context h r db []) (S.empty,Clean) + (a,Dual db) <- evalRWST (runErrorT act) (Context h r db []) (S.empty,Clean) + case a of + Right _ -> putStrLn "Success!" + Left e -> putStrLn $ "cake: " ++ show e hClose h return db @@ -219,7 +231,7 @@ let rs = parse r completeResults f case rs of Right [x] -> return (Just x) - Right _ -> fail $ "More than one rule for file " ++ f + Right _ -> throwError $ CakeError $ "More than one rule for file " ++ f Left e -> do debug $ "No rule for file: " ++ f -- debug $ "Parser says: " ++ show e @@ -233,18 +245,9 @@ let st = case s of Clean -> "O" Dirty -> "X" - liftIO $ hPutStrLn h $ "cake: " ++ st ++ " "++ concat (map (++": ") $ reverse $ map show 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) = fileStamp f --} + liftIO $ hPutStrLn h $ st ++ " "++ concat (map (++": ") $ reverse $ map show ps) ++ x +-- | Return a stamp (hash) for a file fileStamp f = liftIO $ do e <- doesFileExist f Stamp <$> if e @@ -253,6 +256,7 @@ clobber = RWS.modify $ second $ const Dirty +-- | Run the action in only in a clobbered state cut x = do (_,s) <- RWS.get case s of @@ -267,7 +271,7 @@ case r of Nothing -> do e <- liftIO $ doesFileExist f - when (not e) $ fail $ "No rule to create " ++ f + when (not e) $ throwError $ CakeError $ "No rule to create " ++ f debug $ "using existing file" use f return () diff --git a/Cake/Marxup.hs b/Cake/Marxup.hs new file mode 100644 --- /dev/null +++ b/Cake/Marxup.hs @@ -0,0 +1,40 @@ +module Cake.Marxup where + +import Cake.Core +import Cake.Rules +import Cake.Process +import System.FilePath + +import Parsek + +ghcMake x = produce x $ do + let src = x <.> "hs" + need src + system ["ghc", "-o", x, "--make", src] + + +marxup x = do + produce (x <.> "tex") $ do + ghcMake x + cut $ + system $ ["./" ++ x] + produce (x <.> "mp") $ return () + +mpost x = system ["mpost", x] + +remove x = system ["rm", "-f", x] + +pdf_marxup x = produce (x <.> "pdf") $ do + marxup x + let delayed = x ++ "-delayed.mp" + produce delayed $ do + let mp = x <.> "mp" + need mp + cut $ do + remove delayed + mpost mp + mpost mp + + cut $ _pdflatex x + + diff --git a/Cake/Process.hs b/Cake/Process.hs --- a/Cake/Process.hs +++ b/Cake/Process.hs @@ -12,7 +12,6 @@ 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 @@ -33,7 +32,7 @@ succeed :: Act ExitCode -> Act () succeed act = do code <- act - when (code /= ExitSuccess) $ fail "Command returned non-zero exitcode." + when (code /= ExitSuccess) $ throwError $ ProcessError code system xs = succeed $ system' xs processIO c a i o = succeed $ processIO' c a i o diff --git a/Cake/Rules.hs b/Cake/Rules.hs --- a/Cake/Rules.hs +++ b/Cake/Rules.hs @@ -96,21 +96,19 @@ pdf_tex = simple ".pdf" ".tex" $ \o i -> system ["latexmk","-pdf",i] +argsOf s = map (init . (drop $ 2 + length s)) . filter (("\\" ++ s ++ "{") `isPrefixOf`) + getBibFiles input = distill (Custom ["bibfiles",input]) $ do - 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 return $ Text bibs -includedTex input = do - ls <- map (drop 7) . filter ("\\input{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input - let inputs = map (++".tex") $ case ls of - [] -> [] - (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l - return $ inputs +s ++? e = if e `isSuffixOf` s then s else s ++ e +includedTex input = map (++? ".tex") . argsOf "input" . lines <$> Cake.Rules.readFile input + chaseDeps i = do is <- includedTex i mapM_ chaseDeps is @@ -122,9 +120,7 @@ pdf = c ++ ".pdf" bbl = c ++ ".bbl" produce pdf $ do - - -- hack: if nothing changed in the aux file, there is no need to - -- do the final pdflatex, because pdflatex has already produced the tex file. + produce' aux $ do produce bbl $ do produce' aux $ do @@ -138,6 +134,8 @@ cut $ _bibtex c cut $ _pdflatex c + -- hack: if nothing changed in the aux file, there is no need to + -- do the final pdflatex, because pdflatex has already produced the tex file. cut $ do _pdflatex c overwrote aux return () diff --git a/cake.cabal b/cake.cabal --- a/cake.cabal +++ b/cake.cabal @@ -1,5 +1,5 @@ name: cake -version: 0.3.2.1 +version: 0.4.0.0 category: Development synopsis: A build-system library and driver description: @@ -9,7 +9,6 @@ author: Jean-Philippe Bernardy maintainer: jeanphilippe.bernardy@gmail.com Cabal-Version: >= 1.12 -tested-with: GHC==6.12.1 tested-with: GHC==7.4.1 build-type: Simple @@ -28,7 +27,7 @@ build-depends: pureMD5==2.1.* build-depends: split==0.1.* - exposed-modules: Cake, Cake.Core, Cake.Rules, Cake.Process, Parsek + exposed-modules: Cake, Cake.Core, Cake.Rules, Cake.Process, Cake.Marxup, Parsek executable cake default-language: Haskell2010