module Cake.Core (
Rule,
P, (==>),
Act,
cake,
need, needs,
list,
produce, produces,
cut, independently,
debug,
distill,
fileStamp,
shielded,
use,
updates,
Question(..),
Answer(..),
Failure(..),
module Control.Applicative,
throwError,
) where
import Data.Digest.Pure.MD5
import qualified Data.ByteString.Lazy as B
import System.Directory
import System.FilePath
import Control.Applicative
import Control.Monad.RWS hiding (put,get)
import qualified Control.Monad.RWS as RWS
import Control.Monad.Error
import Text.ParserCombinators.Parsek (completeResults, parse, Parser)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Binary hiding (put,get)
import System.Exit
import Control.Arrow (second,first)
import Data.DeriveTH
import Data.Binary
import System.IO
data Question = FileContents FilePath
| Listing FilePath String
| Custom [String]
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 )
instance Show Question where
show (FileContents f) = "{"++f++"}"
show (Listing f ext) = "("++f++"/*"++ext++")"
show (Custom c) = show c
type DB = M.Map Question Answer
type Produced = S.Set FilePath
type P = Parser Char
type Rule = P (Act ())
type State = (Produced,Status)
type Written = Dual DB
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)
data Status = Clean | Dirty
deriving (Eq,Ord)
instance Error Failure where
noMsg = Panic
strMsg = CakeError
(==>) :: P x -> (x -> Act a) -> Rule
p ==> a = (\s -> do a s;return ()) <$> p
databaseFile = ".cake"
logFile = ".cake.log"
cake :: Rule -> Act () -> IO ()
cake rule action = do
e <- doesFileExist databaseFile
oldDB <- if e
then decodeFile databaseFile
else return $ M.empty
newAnswers <- runAct rule oldDB action
let newDB = newAnswers <> oldDB
putStrLn $ "Database is:"
forM_ (M.assocs newDB) $ \(k,v) ->
putStrLn $ (show k) ++ " => " ++ (show v)
encodeFile databaseFile newDB
produced :: FilePath -> Act Bool
produced f = do
(ps,_) <- RWS.get
return $ f `S.member` ps
modCx q (Context {..}) = Context {ctxProducing = q:ctxProducing,..}
distill :: Question -> Act Answer -> Act Answer
distill q act = local (modCx q) $ do
debug $ "Starting to answer: " ++ show q
db <- ctxDB <$> ask
a1 <- refresh q $ noClobber act
let same = Just a1 == M.lookup q db
debug $ "Old answer: " ++ show (M.lookup q db)
debug $ "New answer: " ++ show a1
when (not same) clobber
debug $ "Same? " ++ show same
return a1
refresh :: Question -> Act Answer -> Act Answer
refresh q act =
do a <- act
tell (Dual $ M.singleton q a)
return a
`catchError` \ e -> do
tell (Dual $ M.singleton q $ Failed e)
throwError e
produce x = produces [x]
produces :: [FilePath] -> Act () -> Act ()
produces fs a = do
ps <- mapM produced fs
when (not $ and ps) $ updates fs a
updates :: [FilePath] -> Act () -> Act ()
updates [] a = a
updates (f:fs) a = distill (FileContents f) (do
e <- liftIO $ doesFileExist f
updates fs (when (not e) clobber >> a)
modify $ first $ S.insert f
fileStamp f) >> return ()
list directory extension = do
Text x <- distill (Listing directory extension) $ do
files <- filter (filt . takeExtension) <$> liftIO (getDirectoryContents directory)
return $ Text (map (directory </>) files)
return x
where filt = if null extension then const True else (== '.':extension)
use f = distill (FileContents f) (fileStamp f)
overwrote :: FilePath -> Act Answer
overwrote f = refresh (FileContents f) (fileStamp f)
shielded :: Act a -> Act a
shielded a = do
(ps,s) <- RWS.get
RWS.put (ps,Clean)
x <- a
(ps',_) <- RWS.get
RWS.modify (second (const s))
return x
noClobber :: Act a -> Act a
noClobber a = do
s <- snd <$> RWS.get
x <- a
RWS.modify (second (const s))
return x
independently :: [Act a] -> Act ()
independently as = do
(ps,s) <- RWS.get
ds <- forM as $ \a -> do
RWS.modify (second (const s))
a
snd <$> RWS.get
RWS.modify (second (const (maximum $ s:ds)))
runAct :: Rule -> DB -> Act () -> IO DB
runAct r db (Act act) = do
h <- openFile logFile WriteMode
(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
findRule :: FilePath -> Act (Maybe (Act ()))
findRule f = do
r <- ctxRule <$> ask
let rs = parse r completeResults f
case rs of
Right [x] -> return (Just x)
Right _ -> throwError $ CakeError $ "More than one rule for file " ++ f
Left e -> do
debug $ "No rule for file: " ++ f
return Nothing
debug :: String -> Act ()
debug x = do
h <- ctxHandle <$> ask
ps <- ctxProducing <$> ask
(_,s) <- RWS.get
let st = case s of
Clean -> "O"
Dirty -> "X"
liftIO $ hPutStrLn h $ st ++ " "++ concat (map (++": ") $ reverse $ map show ps) ++ x
fileStamp :: FilePath -> Act Answer
fileStamp f = liftIO $ do
e <- doesFileExist f
Stamp <$> if e
then Just <$> md5 <$> B.readFile f
else return Nothing
clobber = RWS.modify $ second $ (const Dirty)
cut :: Act () -> Act ()
cut x = do
(_,s) <- RWS.get
case s of
Clean -> debug $ "Clean state; skipping."
Dirty -> x
need :: FilePath -> Act ()
need f = do
debug $ "Need: " ++ f
r <- findRule f
case r of
Nothing -> do
e <- liftIO $ doesFileExist f
when (not e) $ throwError $ CakeError $ "No rule to create " ++ f
debug $ "using existing file"
use f
return ()
Just a -> a
needs = independently . map need