{-# LANGUAGE ImpredicativeTypes, ScopedTypeVariables #-}

-- | Monadic tasks, as used by Excel, Shake and other build systems.
-- Dependencies of monadic tasks can only be discovered dynamically, i.e. during
-- their execution.
module Build.Task.Monad (
    track, trackPure, isInput, computePure, compute, liftMaybe, liftEither
    ) where

import Control.Monad.Trans
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
import Data.Functor.Identity
import Data.Maybe

import Build.Store
import Build.Task

-- | Execute a monadic task on a pure store @k -> v@, tracking the dependencies.
trackPure :: Task Monad k v -> (k -> v) -> (v, [k])
trackPure :: forall k v. Task Monad k v -> (k -> v) -> (v, [k])
trackPure Task Monad k v
task k -> v
fetch = Writer [k] v -> (v, [k])
forall w a. Writer w a -> (a, w)
runWriter (Writer [k] v -> (v, [k])) -> Writer [k] v -> (v, [k])
forall a b. (a -> b) -> a -> b
$ (k -> Writer [k] v) -> Writer [k] v
Task Monad k v
task (\k
k -> (v, [k]) -> Writer [k] v
forall a. (a, [k]) -> WriterT [k] Identity a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (k -> v
fetch k
k, [k
k]))

-- | Execute a monadic task using an effectful fetch function @k -> m v@,
-- tracking the dependencies.
track :: forall m k v. Monad m => Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track :: forall (m :: * -> *) k v.
Monad m =>
Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track Task Monad k v
task k -> m v
fetch = WriterT [(k, v)] m v -> m (v, [(k, v)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(k, v)] m v -> m (v, [(k, v)]))
-> WriterT [(k, v)] m v -> m (v, [(k, v)])
forall a b. (a -> b) -> a -> b
$ (k -> WriterT [(k, v)] m v) -> WriterT [(k, v)] m v
Task Monad k v
task k -> WriterT [(k, v)] m v
trackingFetch
  where
    trackingFetch :: k -> WriterT [(k, v)] m v
    trackingFetch :: k -> WriterT [(k, v)] m v
trackingFetch k
k = do
        v
v <- m v -> WriterT [(k, v)] m v
forall (m :: * -> *) a. Monad m => m a -> WriterT [(k, v)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m v -> WriterT [(k, v)] m v) -> m v -> WriterT [(k, v)] m v
forall a b. (a -> b) -> a -> b
$ k -> m v
fetch k
k
        [(k, v)] -> WriterT [(k, v)] m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(k
k, v
v)]
        v -> WriterT [(k, v)] m v
forall a. a -> WriterT [(k, v)] m a
forall (m :: * -> *) a. Monad m => a -> m a
return v
v

-- | Given a description of tasks, check if a key is input.
isInput :: Tasks Monad k v -> k -> Bool
isInput :: forall k v. Tasks Monad k v -> k -> Bool
isInput Tasks Monad k v
tasks = Maybe (Task Monad k v) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Task Monad k v) -> Bool) -> Tasks Monad k v -> k -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tasks Monad k v
tasks

-- | Run a task with a pure lookup function.
computePure :: Task Monad k v -> (k -> v) -> v
computePure :: forall k v. Task Monad k v -> (k -> v) -> v
computePure Task Monad k v
task k -> v
store = Identity v -> v
forall a. Identity a -> a
runIdentity (Identity v -> v) -> Identity v -> v
forall a b. (a -> b) -> a -> b
$ (k -> Identity v) -> Identity v
Task Monad k v
task (v -> Identity v
forall a. a -> Identity a
Identity (v -> Identity v) -> (k -> v) -> k -> Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> v
store)

-- | Run a task in a given store.
compute :: Task Monad k v -> Store i k v -> v
compute :: forall k v i. Task Monad k v -> Store i k v -> v
compute Task Monad k v
task Store i k v
store = Identity v -> v
forall a. Identity a -> a
runIdentity (Identity v -> v) -> Identity v -> v
forall a b. (a -> b) -> a -> b
$ (k -> Identity v) -> Identity v
Task Monad k v
task (\k
k -> v -> Identity v
forall a. a -> Identity a
Identity (k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
k Store i k v
store))

-- | Convert a task with a total lookup function @k -> m v@ into a task with a
-- partial lookup function @k -> m (Maybe v)@. This essentially lifts the task
-- from the type of values @v@ to @Maybe v@, where the result @Nothing@
-- indicates that the task failed because of a missing dependency.
liftMaybe :: Task Monad k v -> Task Monad k (Maybe v)
liftMaybe :: forall k v. Task Monad k v -> Task Monad k (Maybe v)
liftMaybe Task Monad k v
task k -> f (Maybe v)
fetch = MaybeT f v -> f (Maybe v)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT f v -> f (Maybe v)) -> MaybeT f v -> f (Maybe v)
forall a b. (a -> b) -> a -> b
$ (k -> MaybeT f v) -> MaybeT f v
Task Monad k v
task (f (Maybe v) -> MaybeT f v
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (f (Maybe v) -> MaybeT f v)
-> (k -> f (Maybe v)) -> k -> MaybeT f v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f (Maybe v)
fetch)

-- | Convert a task with a total lookup function @k -> m v@ into a task with a
-- lookup function that can throw exceptions @k -> m (Either e v)@. This
-- essentially lifts the task from the type of values @v@ to @Either e v@, where
-- the result @Left e@ indicates that the task failed because of a failed
-- dependency lookup, and @Right v@ yeilds the value otherwise.
liftEither :: Task Monad k v -> Task Monad k (Either e v)
liftEither :: forall k v e. Task Monad k v -> Task Monad k (Either e v)
liftEither Task Monad k v
task k -> f (Either e v)
fetch = ExceptT e f v -> f (Either e v)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e f v -> f (Either e v))
-> ExceptT e f v -> f (Either e v)
forall a b. (a -> b) -> a -> b
$ (k -> ExceptT e f v) -> ExceptT e f v
Task Monad k v
task (f (Either e v) -> ExceptT e f v
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (f (Either e v) -> ExceptT e f v)
-> (k -> f (Either e v)) -> k -> ExceptT e f v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f (Either e v)
fetch)