cake-0.1.0: Cake/Core.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, TemplateHaskell, RecordWildCards  #-}

module Cake.Core (
  -- * Patterns and rules.
  Rule,
  P, (==>),
  
  -- * High-level interface
  Act,             
  cake,
  need,           
  -- * Mid-level interface
  produce,
  use,
  -- * Low-level interface
  shielded,
  debug,
  query,
  cut,
  Question(..),
  Answer(..),
  -- * Re-exports
  module Control.Applicative,
  ) where

import 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 hiding (put,get)
import qualified Control.Monad.RWS as RWS
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

data Question = Stamp FilePath 
              | Listing FilePath String
--              | Option [String]
              deriving (Eq, Ord, Show)
$( derive makeBinary ''Question )             
                         
data Answer = Stamp' (Maybe MD5Digest) 
            | Text [String]
            deriving (Eq, Show)
$( derive makeBinary ''Answer )             
  
type DB = M.Map Question Answer
type Produced = S.Set FilePath      

type P = Parser Char

-- | Rules map names of files to actions building them.
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 Context = Context {ctxRule :: Rule, ctxDB :: DB, ctxProducing :: [FilePath]}
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.

data Status = Clean | Dirty 
            deriving Eq
  
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"

-- | Run an action in the context of a set of rules.
cake :: Rule -> Act () -> IO ()
cake rule action = do
  e <- doesFileExist databaseFile 
  oldDB <- if e 
    then decodeFile databaseFile
    else return $ M.empty
  newDB <- runAct rule oldDB action
  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

produce :: FilePath -> Act () -> Act ()
produce f a = local modCx $ do
  p <- produced f
  -- Do nothing if the file is already produced.
  when (not p) $ do debug $ "starting production"
                    shielded $ do e <- liftIO $ doesFileExist f
                                  when (not e) clobber 
                                  a
                                  -- when (not e) $ fail $ "Action failed to create " ++ f
                                  
                    use f        -- If the new file has changed, then set dirty flag. 
                    modify $ first $ S.insert f   -- remember that the file has been produced already
 where modCx (Context {..}) = Context {ctxProducing = f:ctxProducing,..}

-- | Mark that a file is used. No dependency is created on this file
-- though.
use f = query (Stamp 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 -- for example we already have determined that
-- another goal depends on what we're going to perform. The dirty flag
-- must be set independently in the context if the produced object is
-- not present.
shielded :: Act () -> Act ()
shielded a = do 
  (ps,s) <- RWS.get
  RWS.put (ps,Clean)
  a
  (ps',_) <- RWS.get
  RWS.put (ps',s)


runAct :: Rule -> DB -> Act () -> IO DB
runAct r db (Act act) = do 
  (_a,Dual db) <- evalRWST act (Context r db []) (S.empty,Clean)
  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 _ -> fail $ "More than one rule for file " ++ f
    Left e -> do 
      debug $ "No rule for file: " ++ f
      -- debug $ "Parser says: " ++ show e
      return Nothing
     
           
debug x = do 
  ps <- ctxProducing <$> ask
  liftIO $ putStrLn $ "cake: " ++ concat (map (++": ") $ reverse 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) = 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 (Dual $ M.singleton q a)
  db <- ctxDB <$> ask
  let a0 = M.lookup q db
  when (a0 /= Just a) $ do
    debug $ "Question has not the same answer: " ++ show q
    clobber
  return $ a
  
  
clobber = RWS.modify $ second $ const Dirty

cut x = do
  (_,s) <- RWS.get
  case s of
    Clean -> debug $ "Clean state; skipping."
    Dirty -> x

-- | Try to build a file using known rules; then mark it as used.
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
      use f
      debug $ "File exists: " ++ f
    Just a -> a
  return ()