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 (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
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
instance Applicative P where
(<*>) = ap
pure = return
instance Alternative P where
(<|>) = (Parsek.<|>)
empty = Parsek.pzero
(==>) :: 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