cake-0.0.1: Cake/Core.hs

module Cake.Core (Pattern, (==>),
                  cake,
                  query,
                  cut,
                  promise,
                  need,                  
                  debug,
                  module Control.Applicative,
                  Act,             
                 ) where

import "pureMD5" Data.Digest.Pure.MD5
-- import Data.Digest.OpenSSL.MD5 -- "nano-md5" -- md5sum

import qualified Data.ByteString.Lazy as B
import System.Directory
import System.FilePath
import Control.Applicative
import Control.Monad (when)
import Control.Monad.RWS
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

instance Applicative P where
  (<*>) = ap
  pure = return

instance Alternative P where
  (<|>) = (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 ==> a = (\s -> do a s;return ()) <$> p

newtype LocalR = LocalR {fromLocalR :: P (Act ())}


cakeFile = ".cake"

cake :: [FilePath] -> Rule -> IO ()
cake targets rule = do
  e <- doesFileExist cakeFile 
  oldDB <- if e 
    then decodeFile cakeFile
    else return $ M.empty
  newDB <- runAct rule oldDB $ mapM_ need targets
  putStrLn $ "Database is:"
  putStrLn (groom newDB)
  encodeFile cakeFile newDB


newtype Question = Stamp FilePath deriving (Eq, Ord, Binary, Show)

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

-- 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))


runAct r db act = do 
  (_a,db) <- evalRWST act (LocalR r,db) Clean 
  return db    

findRule :: FilePath -> Act (Maybe (Act ()))
findRule f = do
  (LocalR r,_) <- ask
  let rs = parse r completeResults f
  case rs of
    Right [x] -> return (Just x)
    Right _ -> fail $ "More than one rule for file " ++ f
    Left e -> do 
      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 
  
runQuery :: Question -> IO Answer          
runQuery (Stamp f) = do
  e <- doesFileExist f
  Stamp' <$> if e 
    then Just <$> md5 <$> B.readFile f
    else return Nothing

query :: Question -> Act Answer
query q = do
  a <- liftIO $ runQuery q
  tell (M.singleton q a)
  (_,db) <- ask
  let a0 = M.lookup q db
  when (a0 /= Just a) $ do
    debug $ "Question has not the same answer: " ++ show q
    put Dirty
  return $ a
  
cut x = do
  d <- get
  case d 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) $ fail $ "No rule to create " ++ f
      debug $ "File exists: " ++ f
    Just a -> promise f a
  query (Stamp f)
  return ()