{-# 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 :: Cache
emptyCache = Cache
empty

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

-- | Retrieve a value from cache.
fromCache :: Binary a => Cache -> Maybe a
fromCache :: Cache -> Maybe a
fromCache cache :: Cache
cache =
    case Cache -> Either (Cache, ByteOffset, String) (Cache, ByteOffset, a)
forall a.
Binary a =>
Cache -> Either (Cache, ByteOffset, String) (Cache, ByteOffset, a)
decodeOrFail Cache
cache of
        Left _          -> Maybe a
forall a. Maybe a
Nothing
        Right (_, _, x :: a
x) -> a -> Maybe a
forall a. a -> Maybe a
Just a
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 (MustRun -> MustRun -> Bool
(MustRun -> MustRun -> Bool)
-> (MustRun -> MustRun -> Bool) -> Eq MustRun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MustRun -> MustRun -> Bool
$c/= :: MustRun -> MustRun -> Bool
== :: MustRun -> MustRun -> Bool
$c== :: MustRun -> MustRun -> Bool
Eq)


lowerMustRun :: MustRun -> MustRun
lowerMustRun :: MustRun -> MustRun
lowerMustRun MustRunAll = MustRun
MustRunAll
lowerMustRun x :: MustRun
x = MustRun
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 :: Context b -> (Maybe a, Context b)
fromContext c :: Context b
c =
    let r :: MustRun
r = Context b -> MustRun
forall a. Context a -> MustRun
mustRun Context b
c in
    if MustRun
r MustRun -> MustRun -> Bool
forall a. Eq a => a -> a -> Bool
/= MustRun
NoMust then (Maybe a
forall a. Maybe a
Nothing, Context b
c {mustRun :: MustRun
mustRun = MustRun -> MustRun
lowerMustRun MustRun
r})
    else (Cache -> Maybe a
forall a. Binary a => Cache -> Maybe a
fromCache (Context b -> Cache
forall a. Context a -> Cache
cache Context b
c), Context b
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
    { Context a -> String
inputDir    :: FilePath        -- ^ Input root directory
    , Context a -> String
outputDir   :: FilePath        -- ^ Output root directory
    , Context a -> String
currentDir  :: FilePath        -- ^ Current directory
    , Context a -> UTCTime
timestamp   :: UTCTime         -- ^ Timestamp of the last run
    , Context a -> [Pattern]
forceFiles  :: [Pattern]       -- ^ Files marked as dirty
    , Context a -> MustRun
mustRun     :: MustRun         -- ^ Whether the current task must run
    , Context a -> Cache
cache       :: Cache           -- ^ Local cache
    , Context a -> a
inputValue  :: a               -- ^ Input value
    } deriving (a -> Context b -> Context a
(a -> b) -> Context a -> Context b
(forall a b. (a -> b) -> Context a -> Context b)
-> (forall a b. a -> Context b -> Context a) -> Functor Context
forall a b. a -> Context b -> Context a
forall a b. (a -> b) -> Context a -> Context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Context b -> Context a
$c<$ :: forall a b. a -> Context b -> Context a
fmap :: (a -> b) -> Context a -> Context b
$cfmap :: forall a b. (a -> b) -> Context a -> Context b
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 :: (Context a -> m b) -> Recipe m a b
nonCached f :: Context a -> m b
f = (Context a -> m (b, Cache)) -> Recipe m a b
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe \c :: Context a
c -> (, Cache
emptyCache) (b -> (b, Cache)) -> m b -> m (b, Cache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context a -> m b
f Context a
c {cache :: Cache
cache = Cache
emptyCache}


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


instance Functor m => Functor (Recipe m a) where
    fmap :: (a -> b) -> Recipe m a a -> Recipe m a b
fmap f :: a -> b
f (Recipe r :: Context a -> m (a, Cache)
r) = (Context a -> m (b, Cache)) -> Recipe m a b
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe \c :: Context a
c -> (a -> b) -> (a, Cache) -> (b, Cache)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f ((a, Cache) -> (b, Cache)) -> m (a, Cache) -> m (b, Cache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context a -> m (a, Cache)
r Context a
c


instance Monad m => Applicative (Recipe m a) where
    pure :: a -> Recipe m a a
pure  = (Context a -> m (a, Cache)) -> Recipe m a a
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe ((Context a -> m (a, Cache)) -> Recipe m a a)
-> (a -> Context a -> m (a, Cache)) -> a -> Recipe m a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, Cache) -> Context a -> m (a, Cache)
forall a b. a -> b -> a
const (m (a, Cache) -> Context a -> m (a, Cache))
-> (a -> m (a, Cache)) -> a -> Context a -> m (a, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Cache) -> m (a, Cache)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Cache) -> m (a, Cache))
-> (a -> (a, Cache)) -> a -> m (a, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Cache
emptyCache)

    <*> :: Recipe m a (a -> b) -> Recipe m a a -> Recipe m a b
(<*>) = Recipe m a (a -> b) -> Recipe m a a -> Recipe m a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap


splitCache :: Cache -> (Cache, Cache)
splitCache :: Cache -> (Cache, Cache)
splitCache = (Cache, Cache) -> Maybe (Cache, Cache) -> (Cache, Cache)
forall a. a -> Maybe a -> a
fromMaybe (Cache
emptyCache, Cache
emptyCache) (Maybe (Cache, Cache) -> (Cache, Cache))
-> (Cache -> Maybe (Cache, Cache)) -> Cache -> (Cache, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> Maybe (Cache, Cache)
forall a. Binary a => Cache -> Maybe a
fromCache


instance Monad m => Monad (Recipe m a) where
    Recipe r :: Context a -> m (a, Cache)
r >>= :: Recipe m a a -> (a -> Recipe m a b) -> Recipe m a b
>>= f :: a -> Recipe m a b
f = (Context a -> m (b, Cache)) -> Recipe m a b
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe \c :: Context a
c -> do
        let (cr :: Cache
cr, cf :: Cache
cf) = Cache -> (Cache, Cache)
splitCache (Context a -> Cache
forall a. Context a -> Cache
cache Context a
c)
        (x :: a
x, cr' :: Cache
cr') <- Context a -> m (a, Cache)
r Context a
c   {cache :: Cache
cache = Cache
cr}
        (y :: b
y, cf' :: Cache
cf') <- Recipe m a b -> Context a -> m (b, Cache)
forall (m :: * -> *) a b. Recipe m a b -> Context a -> m (b, Cache)
runRecipe (a -> Recipe m a b
f a
x) Context a
c {cache :: Cache
cache = Cache
cf}
        (b, Cache) -> m (b, Cache)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
y, (Cache, Cache) -> Cache
forall a. Binary a => a -> Cache
toCache (Cache
cr', Cache
cf'))

    -- parallelism for free?
    Recipe r :: Context a -> m (a, Cache)
r >> :: Recipe m a a -> Recipe m a b -> Recipe m a b
>> Recipe s :: Context a -> m (b, Cache)
s = (Context a -> m (b, Cache)) -> Recipe m a b
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe \c :: Context a
c -> do
        let (cr :: Cache
cr, cs :: Cache
cs) = Cache -> (Cache, Cache)
splitCache (Context a -> Cache
forall a. Context a -> Cache
cache Context a
c)
        (_, cr' :: Cache
cr') <- Context a -> m (a, Cache)
r Context a
c {cache :: Cache
cache = Cache
cr}
        (y :: b
y, cs' :: Cache
cs') <- Context a -> m (b, Cache)
s Context a
c {cache :: Cache
cache = Cache
cs}
        (b, Cache) -> m (b, Cache)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
y, (Cache, Cache) -> Cache
forall a. Binary a => a -> Cache
toCache (Cache
cr', Cache
cs'))


instance MonadIO m => MonadIO (Recipe m a) where
    liftIO :: IO a -> Recipe m a a
liftIO = (Context a -> m a) -> Recipe m a a
forall (m :: * -> *) a b.
Functor m =>
(Context a -> m b) -> Recipe m a b
nonCached ((Context a -> m a) -> Recipe m a a)
-> (IO a -> Context a -> m a) -> IO a -> Recipe m a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Context a -> m a
forall a b. a -> b -> a
const (m a -> Context a -> m a)
-> (IO a -> m a) -> IO a -> Context a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


instance MonadFail m => MonadFail (Recipe m a) where
    fail :: String -> Recipe m a a
fail = (Context a -> m (a, Cache)) -> Recipe m a a
forall (m :: * -> *) a b.
(Context a -> m (b, Cache)) -> Recipe m a b
Recipe ((Context a -> m (a, Cache)) -> Recipe m a a)
-> (String -> Context a -> m (a, Cache)) -> String -> Recipe m a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, Cache) -> Context a -> m (a, Cache)
forall a b. a -> b -> a
const (m (a, Cache) -> Context a -> m (a, Cache))
-> (String -> m (a, Cache)) -> String -> Context a -> m (a, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (a, Cache)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail


instance (Monad m, Semigroup b) => Semigroup (Recipe m a b) where
    x :: Recipe m a b
x <> :: Recipe m a b -> Recipe m a b -> Recipe m a b
<> y :: Recipe m a b
y = (b -> b -> b) -> Recipe m a b -> Recipe m a b -> Recipe m a b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) Recipe m a b
x Recipe m a b
y


instance (Monad m, Monoid b) => Monoid (Recipe m a b) where
    mempty :: Recipe m a b
mempty = b -> Recipe m a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty