Internal.hs

{-# LANGUAGE DeriveFunctor    #-}

-- | Defines recipes, how they compose and evaluate.
module Achille.Internal
    ( Cache
    , emptyCache
    , toCache
    , fromCache
    , fromContext
    , MustRun(..)
    , Context(..)
    , Recipe(..)
    , Task
    , runRecipe
    , nonCached
    ) where

import Prelude hiding (fail, liftIO)

import Data.Binary             (Binary, encode, decodeOrFail)
import Data.Maybe              (fromMaybe)
import Data.Functor            (void)
import Control.Monad           (ap)
import Control.Monad.IO.Class  (MonadIO, liftIO)
import Control.Monad.Fail      (MonadFail, fail)
import Control.Applicative     (liftA2)
import Data.Time.Clock         (UTCTime)
import Data.ByteString.Lazy    (ByteString, empty)
import Data.Bifunctor          (first, second)
import System.FilePath.Glob    (Pattern)


-- | A cache is a lazy bytestring.
type Cache = ByteString


-- | The empty cache.
emptyCache :: Cache
emptyCache = empty

-- | Cache a value.
toCache :: Binary a => a -> Cache
toCache = encode

-- | Retrieve a value from cache.
fromCache :: Binary a => Cache -> Maybe a
fromCache cache =
    case decodeOrFail cache of
        Left _          -> Nothing
        Right (_, _, x) -> Just x


-- | Local rules for running a recipe
data MustRun = MustRunOne  -- ^ The current recipe, and only this one, must run
             | MustRunAll  -- ^ All subsequent recipes must run
             | NoMust      -- ^ No obligation, the current recipe will be run as normal
             deriving (Eq)


lowerMustRun :: MustRun -> MustRun
lowerMustRun MustRunAll = MustRunAll
lowerMustRun x = NoMust

-- | Try to load a value from the cache,
--   while respecting the rule for running the recipe.
--   That is, if the rule must run, nothing will be returned.
--   We also lower the run rule in the returned context, if possible.
--
--   The types are not explicit enough, should rewrite.
fromContext :: Binary a => Context b -> (Maybe a, Context b)
fromContext c =
    let r = mustRun c in
    if r /= NoMust then (Nothing, c {mustRun = lowerMustRun r})
    else (fromCache (cache c), c)



-- | Description of a computation producing a value b given some input a.
newtype Recipe m a b = Recipe (Context a -> m (b, Cache))


-- | Context in which a recipe is being executed.
data Context a = Context
    { inputDir    :: FilePath        -- ^ Input root directory
    , outputDir   :: FilePath        -- ^ Output root directory
    , currentDir  :: FilePath        -- ^ Current directory
    , timestamp   :: UTCTime         -- ^ Timestamp of the last run
    , forceFiles  :: [Pattern]       -- ^ Files marked as dirty
    , mustRun     :: MustRun         -- ^ Whether the current task must run
    , cache       :: Cache           -- ^ Local cache
    , inputValue  :: a               -- ^ Input value
    } deriving (Functor)


-- | A task is a recipe with no input
type Task m = Recipe m ()


-- | Make a recipe out of a computation that is known not to be cached.
nonCached :: Functor m => (Context a -> m b) -> Recipe m a b
nonCached f = Recipe \c -> (, emptyCache) <$> f c {cache = emptyCache}


-- | Run a recipe with a given context.
runRecipe :: Recipe m a b -> Context a -> m (b, Cache)
runRecipe (Recipe r) = r


instance Functor m => Functor (Recipe m a) where
    fmap f (Recipe r) = Recipe \c -> first f <$> r c


instance Monad m => Applicative (Recipe m a) where
    pure  = Recipe . const . pure . (, emptyCache)

    (<*>) = ap


splitCache :: Cache -> (Cache, Cache)
splitCache = fromMaybe (emptyCache, emptyCache) . fromCache


instance Monad m => Monad (Recipe m a) where
    Recipe r >>= f = Recipe \c -> do
        let (cr, cf) = splitCache (cache c)
        (x, cr') <- r c   {cache = cr}
        (y, cf') <- runRecipe (f x) c {cache = cf}
        pure (y, toCache (cr', cf'))

    -- parallelism for free?
    Recipe r >> Recipe s = Recipe \c -> do
        let (cr, cs) = splitCache (cache c)
        (_, cr') <- r c {cache = cr}
        (y, cs') <- s c {cache = cs}
        pure (y, toCache (cr', cs'))


instance MonadIO m => MonadIO (Recipe m a) where
    liftIO = nonCached . const . liftIO


instance MonadFail m => MonadFail (Recipe m a) where
    fail = Recipe . const . fail


instance (Monad m, Semigroup b) => Semigroup (Recipe m a b) where
    x <> y = liftA2 (<>) x y


instance (Monad m, Monoid b) => Monoid (Recipe m a b) where
    mempty = pure mempty