SelfTracking.hs

{-# LANGUAGE ScopedTypeVariables #-}

-- | This module defines two different strategies of self-tracking, based
-- around the idea of storing task descriptions that can be parsed into a 'Task'.
--
-- * For 'Monad' it works out beautifully. You just store the rule on the disk,
-- and depend on it.
--
-- * For 'Applicative', we generate a fresh 'Task' each time, but have that
-- 'Task' depend on a fake version of the rules. This is a change in the 'Task',
-- but it's one for which the standard implementations tend to cope with just
-- fine. Most applicative systems with self-tracking probably do it this way.
module Build.SelfTracking (
    Key (..), Value (..), selfTrackingM, selfTrackingA
    ) where

import Build.Task

-- | We assume that the fetch passed to a Task is consistent and returns values
-- matching the keys. It is possible to switch to typed tasks to check this
-- assumption at compile time, e.g. see "Build.Task.Typed".
data Key k     = Key k   | KeyTask k
data Value v t = Value v | ValueTask t

-- | Fetch a value.
fetchValue :: Functor f => (Key k -> f (Value v t)) -> k -> f v
fetchValue fetch key = extract <$> fetch (Key key)
  where
    extract (Value v) = v
    extract _ = error "Inconsistent fetch"

-- | Fetch a task description.
fetchValueTask :: Functor f => (Key k -> f (Value v t)) -> k -> f t
fetchValueTask fetch key = extract <$> fetch (KeyTask key)
  where
    extract (ValueTask t) = t
    extract _ = error "Inconsistent fetch"

-- | A model for 'Monad', works beautifully and allows storing the key on the
-- disk.
selfTrackingM :: forall k v t. (t -> Task Monad k v) -> Tasks Monad k t -> Tasks Monad (Key k) (Value v t)
selfTrackingM _      _     (KeyTask _) = Nothing -- Task keys are inputs
selfTrackingM parser tasks (Key     k) = runTask <$> tasks k
  where
    -- Fetch the task description, parse it, and then run the obtained task
    runTask :: Task Monad k t -> Task Monad (Key k) (Value v t)
    runTask act = Task $ \fetch -> do
        task <- parser <$> run act (fetchValueTask fetch)
        Value <$> run task (fetchValue fetch)

-- | The applicative model requires every key to be able to associate with its
-- environment (e.g. a reader somewhere). Does not support cutoff if a key changes.
selfTrackingA :: (t -> Task Applicative k v) -> (k -> t) -> Tasks Applicative (Key k) (Value v t)
selfTrackingA _      _   (KeyTask _) = Nothing -- Task keys are inputs
selfTrackingA parser ask (Key k) = Just $ Task $ \fetch ->
    fetch (KeyTask k) *> (Value <$> run (parser $ ask k) (fetchValue fetch))