{-# LANGUAGE ImpredicativeTypes, FlexibleContexts, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE FlexibleInstances, ConstraintKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}

-- | Build schedulers execute task rebuilders in the right order.
module Build.Scheduler (
    Scheduler,
    topological,
    restarting, Chain,
    restarting2,
    suspending,
    independent
    ) where

import Control.Monad.State
import Control.Monad.Trans.Except
import Data.Bifunctor
import Data.Set (Set)

import Build
import Build.Task
import Build.Task.Applicative
import Build.Task.Monad
import Build.Trace
import Build.Store
import Build.Rebuilder
import Build.Utilities

import qualified Data.Set as Set

type Scheduler c i j k v = Rebuilder c j k v -> Build c i k v

-- | Lift a computation operating on @i@ to @Store i k v@.
liftStore :: State i a -> State (Store i k v) a
liftStore :: forall i a k v. State i a -> State (Store i k v) a
liftStore State i a
x = do
    (a
a, i
newInfo) <- (Store i k v -> (a, i)) -> StateT (Store i k v) Identity (a, i)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (State i a -> i -> (a, i)
forall s a. State s a -> s -> (a, s)
runState State i a
x (i -> (a, i)) -> (Store i k v -> i) -> Store i k v -> (a, i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store i k v -> i
forall i k v. Store i k v -> i
getInfo)
    (Store i k v -> Store i k v) -> StateT (Store i k v) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (i -> Store i k v -> Store i k v
forall i k v. i -> Store i k v -> Store i k v
putInfo i
newInfo)
    a -> State (Store i k v) a
forall a. a -> StateT (Store i k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Lift a computation operating on @Store i k v@ to @Store (i, j) k v@.
liftInfo :: State (Store i k v) a -> State (Store (i, j) k v) a
liftInfo :: forall i k v a j.
State (Store i k v) a -> State (Store (i, j) k v) a
liftInfo State (Store i k v) a
x = do
    Store (i, j) k v
store <- StateT (Store (i, j) k v) Identity (Store (i, j) k v)
forall s (m :: * -> *). MonadState s m => m s
get
    let (a
a, Store i k v
newStore) = State (Store i k v) a -> Store i k v -> (a, Store i k v)
forall s a. State s a -> s -> (a, s)
runState State (Store i k v) a
x (((i, j) -> i) -> Store (i, j) k v -> Store i k v
forall i j k v. (i -> j) -> Store i k v -> Store j k v
mapInfo (i, j) -> i
forall a b. (a, b) -> a
fst Store (i, j) k v
store)
    Store (i, j) k v -> StateT (Store (i, j) k v) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Store (i, j) k v -> StateT (Store (i, j) k v) Identity ())
-> Store (i, j) k v -> StateT (Store (i, j) k v) Identity ()
forall a b. (a -> b) -> a -> b
$ (i -> (i, j)) -> Store i k v -> Store (i, j) k v
forall i j k v. (i -> j) -> Store i k v -> Store j k v
mapInfo (, (i, j) -> j
forall a b. (a, b) -> b
snd ((i, j) -> j) -> (i, j) -> j
forall a b. (a -> b) -> a -> b
$ Store (i, j) k v -> (i, j)
forall i k v. Store i k v -> i
getInfo Store (i, j) k v
store) Store i k v
newStore
    a -> State (Store (i, j) k v) a
forall a. a -> StateT (Store (i, j) k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Update the value of a key in the store. The function takes both the current
-- value (the first argument of type @v@) and the new value (the second argument
-- of type @v@), and can potentially avoid touching the store if the value is
-- unchanged. The current implementation simply ignores the current value, but
-- in future this may be optimised, e.g. by comparing their hashes.
updateValue :: Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue :: forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
key v
_current_value = k -> v -> Store i k v -> Store i k v
forall k v i. Eq k => k -> v -> Store i k v -> Store i k v
putValue k
key

---------------------------------- Topological ---------------------------------
-- | This scheduler constructs the dependency graph of the target key by
-- extracting all (static) dependencies upfront, and then traversing the graph
-- in the topological order, rebuilding keys using the supplied rebuilder.
topological :: forall i k v. Ord k => Scheduler Applicative i i k v
topological :: forall i k v. Ord k => Scheduler Applicative i i k v
topological Rebuilder Applicative i k v
rebuilder Tasks Applicative k v
tasks k
target = State (Store i k v) () -> Store i k v -> Store i k v
forall s a. State s a -> s -> s
execState (State (Store i k v) () -> Store i k v -> Store i k v)
-> State (Store i k v) () -> Store i k v -> Store i k v
forall a b. (a -> b) -> a -> b
$ (k -> State (Store i k v) ()) -> [k] -> State (Store i k v) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ k -> State (Store i k v) ()
build [k]
order
  where
    build :: k -> State (Store i k v) ()
    build :: k -> State (Store i k v) ()
build k
key = case Tasks Applicative k v
tasks k
key of
        Maybe (Task Applicative k v)
Nothing -> () -> State (Store i k v) ()
forall a. a -> StateT (Store i k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Task Applicative k v
task -> do
            Store i k v
store <- StateT (Store i k v) Identity (Store i k v)
forall s (m :: * -> *). MonadState s m => m s
get
            let value :: v
value = k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key Store i k v
store
                newTask :: Task (MonadState i) k v
                newTask :: Task (MonadState i) k v
newTask = Rebuilder Applicative i k v
rebuilder k
key v
value (k -> f v) -> f v
Task Applicative k v
task
                fetch :: k -> State i v
                fetch :: k -> State i v
fetch k
k = v -> State i v
forall a. a -> StateT i Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
k Store i k v
store)
            v
newValue <- State i v -> State (Store i k v) v
forall i a k v. State i a -> State (Store i k v) a
liftStore ((k -> State i v) -> State i v
Task (MonadState i) k v
newTask k -> State i v
fetch)
            (Store i k v -> Store i k v) -> State (Store i k v) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Store i k v -> Store i k v) -> State (Store i k v) ())
-> (Store i k v -> Store i k v) -> State (Store i k v) ()
forall a b. (a -> b) -> a -> b
$ k -> v -> v -> Store i k v -> Store i k v
forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
key v
value v
newValue
    order :: [k]
order = case Graph k -> Maybe [k]
forall k. Ord k => Graph k -> Maybe [k]
topSort ((k -> [k]) -> k -> Graph k
forall k. Ord k => (k -> [k]) -> k -> Graph k
graph k -> [k]
deps k
target) of
        Maybe [k]
Nothing -> [Char] -> [k]
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot build tasks with cyclic dependencies"
        Just [k]
xs -> [k]
xs
    deps :: k -> [k]
deps k
k = [k]
-> (Task Applicative k v -> [k])
-> Maybe (Task Applicative k v)
-> [k]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Task Applicative k v -> [k]
forall k v. Task Applicative k v -> [k]
dependencies (Tasks Applicative k v
tasks k
k)

---------------------------------- Restarting ----------------------------------
-- | 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, e.g. because of a
-- failed dependency lookup, and @Right v@ yields the value otherwise.
try :: Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try :: forall i k v e.
Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try Task (MonadState i) 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 (MonadState i) 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)

-- | The so-called @calculation chain@: the order in which keys were built
-- during the previous build, which is used as the best guess for the current
-- build by Excel and other similar build systems.
type Chain k = [k]

-- | A model of the scheduler used by Excel, which builds keys in the order used
-- in the previous build. If a key cannot be build because its dependencies have
-- changed and a new dependency is still dirty, the corresponding build task is
-- abandoned and the key is moved at the end of the calculation chain, so it can
-- be restarted when all its dependencies are up to date.
restarting :: forall ir k v. Ord k => Scheduler Monad (ir, Chain k) ir k v
restarting :: forall ir k v. Ord k => Scheduler Monad (ir, Chain k) ir k v
restarting Rebuilder Monad ir k v
rebuilder Tasks Monad k v
tasks k
target = State (Store (ir, Chain k) k v) ()
-> Store (ir, Chain k) k v -> Store (ir, Chain k) k v
forall s a. State s a -> s -> s
execState (State (Store (ir, Chain k) k v) ()
 -> Store (ir, Chain k) k v -> Store (ir, Chain k) k v)
-> State (Store (ir, Chain k) k v) ()
-> Store (ir, Chain k) k v
-> Store (ir, Chain k) k v
forall a b. (a -> b) -> a -> b
$ do
    Chain k
chain    <- (Store (ir, Chain k) k v -> Chain k)
-> StateT (Store (ir, Chain k) k v) Identity (Chain k)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((ir, Chain k) -> Chain k
forall a b. (a, b) -> b
snd ((ir, Chain k) -> Chain k)
-> (Store (ir, Chain k) k v -> (ir, Chain k))
-> Store (ir, Chain k) k v
-> Chain k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store (ir, Chain k) k v -> (ir, Chain k)
forall i k v. Store i k v -> i
getInfo)
    Chain k
newChain <- State (Store ir k v) (Chain k)
-> StateT (Store (ir, Chain k) k v) Identity (Chain k)
forall i k v a j.
State (Store i k v) a -> State (Store (i, j) k v) a
liftInfo (State (Store ir k v) (Chain k)
 -> StateT (Store (ir, Chain k) k v) Identity (Chain k))
-> State (Store ir k v) (Chain k)
-> StateT (Store (ir, Chain k) k v) Identity (Chain k)
forall a b. (a -> b) -> a -> b
$ Set k -> Chain k -> State (Store ir k v) (Chain k)
go Set k
forall a. Set a
Set.empty (Chain k -> State (Store ir k v) (Chain k))
-> Chain k -> State (Store ir k v) (Chain k)
forall a b. (a -> b) -> a -> b
$ Chain k
chain Chain k -> Chain k -> Chain k
forall a. [a] -> [a] -> [a]
++ [k
target | k
target k -> Chain k -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Chain k
chain]
    (Store (ir, Chain k) k v -> Store (ir, Chain k) k v)
-> State (Store (ir, Chain k) k v) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Store (ir, Chain k) k v -> Store (ir, Chain k) k v)
 -> State (Store (ir, Chain k) k v) ())
-> (((ir, Chain k) -> (ir, Chain k))
    -> Store (ir, Chain k) k v -> Store (ir, Chain k) k v)
-> ((ir, Chain k) -> (ir, Chain k))
-> State (Store (ir, Chain k) k v) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ir, Chain k) -> (ir, Chain k))
-> Store (ir, Chain k) k v -> Store (ir, Chain k) k v
forall i j k v. (i -> j) -> Store i k v -> Store j k v
mapInfo (((ir, Chain k) -> (ir, Chain k))
 -> State (Store (ir, Chain k) k v) ())
-> ((ir, Chain k) -> (ir, Chain k))
-> State (Store (ir, Chain k) k v) ()
forall a b. (a -> b) -> a -> b
$ \(ir
ir, Chain k
_) -> (ir
ir, Chain k
newChain)
  where
    go :: Set k -> Chain k -> State (Store ir k v) (Chain k)
    go :: Set k -> Chain k -> State (Store ir k v) (Chain k)
go Set k
_    []       = Chain k -> State (Store ir k v) (Chain k)
forall a. a -> StateT (Store ir k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go Set k
done (k
key:Chain k
ks) = case Tasks Monad k v
tasks k
key of
        Maybe (Task Monad k v)
Nothing -> (k
key k -> Chain k -> Chain k
forall a. a -> [a] -> [a]
:) (Chain k -> Chain k)
-> State (Store ir k v) (Chain k) -> State (Store ir k v) (Chain k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set k -> Chain k -> State (Store ir k v) (Chain k)
go (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
key Set k
done) Chain k
ks
        Just Task Monad k v
task -> do
            Store ir k v
store <- StateT (Store ir k v) Identity (Store ir k v)
forall s (m :: * -> *). MonadState s m => m s
get
            let value :: v
value = k -> Store ir k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key Store ir k v
store
                newTask :: Task (MonadState ir) k (Either k v)
                newTask :: Task (MonadState ir) k (Either k v)
newTask = Task (MonadState ir) k v -> Task (MonadState ir) k (Either k v)
forall i k v e.
Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try (Task (MonadState ir) k v -> Task (MonadState ir) k (Either k v))
-> Task (MonadState ir) k v -> Task (MonadState ir) k (Either k v)
forall a b. (a -> b) -> a -> b
$ Rebuilder Monad ir k v
rebuilder k
key v
value (k -> f v) -> f v
Task Monad k v
task
                fetch :: k -> State ir (Either k v)
                fetch :: k -> State ir (Either k v)
fetch k
k | k
k k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
done = Either k v -> State ir (Either k v)
forall a. a -> StateT ir Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either k v -> State ir (Either k v))
-> Either k v -> State ir (Either k v)
forall a b. (a -> b) -> a -> b
$ v -> Either k v
forall a b. b -> Either a b
Right (k -> Store ir k v -> v
forall k i v. k -> Store i k v -> v
getValue k
k Store ir k v
store)
                        | Bool
otherwise           = Either k v -> State ir (Either k v)
forall a. a -> StateT ir Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either k v -> State ir (Either k v))
-> Either k v -> State ir (Either k v)
forall a b. (a -> b) -> a -> b
$ k -> Either k v
forall a b. a -> Either a b
Left k
k
            Either k v
result <- State ir (Either k v) -> State (Store ir k v) (Either k v)
forall i a k v. State i a -> State (Store i k v) a
liftStore ((k -> State ir (Either k v)) -> State ir (Either k v)
Task (MonadState ir) k (Either k v)
newTask k -> State ir (Either k v)
fetch)
            case Either k v
result of
                Left k
dep -> Set k -> Chain k -> State (Store ir k v) (Chain k)
go Set k
done (Chain k -> State (Store ir k v) (Chain k))
-> Chain k -> State (Store ir k v) (Chain k)
forall a b. (a -> b) -> a -> b
$ k
dep k -> Chain k -> Chain k
forall a. a -> [a] -> [a]
: (k -> Bool) -> Chain k -> Chain k
forall a. (a -> Bool) -> [a] -> [a]
filter (k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= k
dep) Chain k
ks Chain k -> Chain k -> Chain k
forall a. [a] -> [a] -> [a]
++ [k
key]
                Right v
newValue -> do
                    (Store ir k v -> Store ir k v) -> StateT (Store ir k v) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Store ir k v -> Store ir k v)
 -> StateT (Store ir k v) Identity ())
-> (Store ir k v -> Store ir k v)
-> StateT (Store ir k v) Identity ()
forall a b. (a -> b) -> a -> b
$ k -> v -> v -> Store ir k v -> Store ir k v
forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
key v
value v
newValue
                    (k
key k -> Chain k -> Chain k
forall a. a -> [a] -> [a]
:) (Chain k -> Chain k)
-> State (Store ir k v) (Chain k) -> State (Store ir k v) (Chain k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set k -> Chain k -> State (Store ir k v) (Chain k)
go (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
key Set k
done) Chain k
ks

-- | An item in the queue comprises a key that needs to be built and a list of
-- keys that are blocked on it. More efficient implementations are possible,
-- e.g. storing blocked keys in a @Map k [k]@ would allow faster queue updates.
type Queue k = [(k, [k])]

-- | Add a key with a list of blocked keys to the queue. If the key is already
-- in the queue, extend its list of blocked keys.
enqueue :: Eq k => k -> [k] -> Queue k -> Queue k
enqueue :: forall k. Eq k => k -> [k] -> Queue k -> Queue k
enqueue k
key [k]
blocked [] = [(k
key, [k]
blocked)]
enqueue k
key [k]
blocked ((k
k, [k]
bs):[(k, [k])]
q)
    | k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
key  = (k
k, [k]
blocked [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
++ [k]
bs) (k, [k]) -> [(k, [k])] -> [(k, [k])]
forall a. a -> [a] -> [a]
: [(k, [k])]
q
    | Bool
otherwise = (k
k, [k]
bs) (k, [k]) -> [(k, [k])] -> [(k, [k])]
forall a. a -> [a] -> [a]
: k -> [k] -> [(k, [k])] -> [(k, [k])]
forall k. Eq k => k -> [k] -> Queue k -> Queue k
enqueue k
key [k]
blocked [(k, [k])]
q

-- | Extract a key and a list of blocked keys from the queue, or return
-- @Nothing@ if the queue is empty.
dequeue :: Queue k -> Maybe (k, [k], Queue k)
dequeue :: forall k. Queue k -> Maybe (k, [k], Queue k)
dequeue []          = Maybe (k, [k], [(k, [k])])
forall a. Maybe a
Nothing
dequeue ((k
k, [k]
bs):[(k, [k])]
q) = (k, [k], [(k, [k])]) -> Maybe (k, [k], [(k, [k])])
forall a. a -> Maybe a
Just (k
k, [k]
bs, [(k, [k])]
q)

-- | A model of the scheduler used by Bazel. We extract a key K from the queue
-- and try to build it. There are now two cases:
-- 1. The build fails because one of the dependencies of K is dirty. In this
--    case we add the dirty dependency to the queue, listing K as blocked by it.
-- 2. The build succeeds, in which case we add all keys that were previously
--    blocked by K to the queue.
restarting2 :: forall k v. (Hashable v, Eq k) => Scheduler Monad (CT k v) (CT k v) k v
restarting2 :: forall k v.
(Hashable v, Eq k) =>
Scheduler Monad (CT k v) (CT k v) k v
restarting2 Rebuilder Monad (CT k v) k v
rebuilder Tasks Monad k v
tasks k
target = State (Store (CT k v) k v) ()
-> Store (CT k v) k v -> Store (CT k v) k v
forall s a. State s a -> s -> s
execState (State (Store (CT k v) k v) ()
 -> Store (CT k v) k v -> Store (CT k v) k v)
-> State (Store (CT k v) k v) ()
-> Store (CT k v) k v
-> Store (CT k v) k v
forall a b. (a -> b) -> a -> b
$ Queue k -> State (Store (CT k v) k v) ()
go (k -> [k] -> Queue k -> Queue k
forall k. Eq k => k -> [k] -> Queue k -> Queue k
enqueue k
target [] Queue k
forall a. Monoid a => a
mempty)
  where
    go :: Queue k -> State (Store (CT k v) k v) ()
    go :: Queue k -> State (Store (CT k v) k v) ()
go Queue k
queue = case Queue k -> Maybe (k, [k], Queue k)
forall k. Queue k -> Maybe (k, [k], Queue k)
dequeue Queue k
queue of
        Maybe (k, [k], Queue k)
Nothing -> () -> State (Store (CT k v) k v) ()
forall a. a -> StateT (Store (CT k v) k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (k
key, [k]
bs, Queue k
q) -> case Tasks Monad k v
tasks k
key of
            Maybe (Task Monad k v)
Nothing -> () -> State (Store (CT k v) k v) ()
forall a. a -> StateT (Store (CT k v) k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Never happens: we have no inputs in the queue
            Just Task Monad k v
task -> do
                Store (CT k v) k v
store <- StateT (Store (CT k v) k v) Identity (Store (CT k v) k v)
forall s (m :: * -> *). MonadState s m => m s
get
                let value :: v
value = k -> Store (CT k v) k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key Store (CT k v) k v
store
                    upToDate :: k -> Bool
upToDate k
k = Tasks Monad k v -> k -> Bool
forall k v. Tasks Monad k v -> k -> Bool
isInput Tasks Monad k v
tasks k
k Bool -> Bool -> Bool
|| Bool -> Bool
not (k -> Store (CT k v) k v -> Bool
forall k v. (Eq k, Hashable v) => k -> Store (CT k v) k v -> Bool
isDirtyCT k
k Store (CT k v) k v
store)
                    newTask :: Task (MonadState (CT k v)) k (Either k v)
                    newTask :: Task (MonadState (CT k v)) k (Either k v)
newTask = Task (MonadState (CT k v)) k v
-> Task (MonadState (CT k v)) k (Either k v)
forall i k v e.
Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try (Task (MonadState (CT k v)) k v
 -> Task (MonadState (CT k v)) k (Either k v))
-> Task (MonadState (CT k v)) k v
-> Task (MonadState (CT k v)) k (Either k v)
forall a b. (a -> b) -> a -> b
$ Rebuilder Monad (CT k v) k v
rebuilder k
key v
value (k -> f v) -> f v
Task Monad k v
task
                    fetch :: k -> State (CT k v) (Either k v)
                    fetch :: k -> State (CT k v) (Either k v)
fetch k
k | k -> Bool
upToDate k
k = Either k v -> State (CT k v) (Either k v)
forall a. a -> StateT (CT k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Either k v
forall a b. b -> Either a b
Right (k -> Store (CT k v) k v -> v
forall k i v. k -> Store i k v -> v
getValue k
k Store (CT k v) k v
store))
                            | Bool
otherwise  = Either k v -> State (CT k v) (Either k v)
forall a. a -> StateT (CT k v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> Either k v
forall a b. a -> Either a b
Left k
k)
                Either k v
result <- State (CT k v) (Either k v)
-> State (Store (CT k v) k v) (Either k v)
forall i a k v. State i a -> State (Store i k v) a
liftStore ((k -> State (CT k v) (Either k v)) -> State (CT k v) (Either k v)
Task (MonadState (CT k v)) k (Either k v)
newTask k -> State (CT k v) (Either k v)
fetch)
                case Either k v
result of
                    Left k
dep -> Queue k -> State (Store (CT k v) k v) ()
go (k -> [k] -> Queue k -> Queue k
forall k. Eq k => k -> [k] -> Queue k -> Queue k
enqueue k
dep (k
keyk -> [k] -> [k]
forall a. a -> [a] -> [a]
:[k]
bs) Queue k
q)
                    Right v
newValue -> do
                        (Store (CT k v) k v -> Store (CT k v) k v)
-> State (Store (CT k v) k v) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Store (CT k v) k v -> Store (CT k v) k v)
 -> State (Store (CT k v) k v) ())
-> (Store (CT k v) k v -> Store (CT k v) k v)
-> State (Store (CT k v) k v) ()
forall a b. (a -> b) -> a -> b
$ k -> v -> v -> Store (CT k v) k v -> Store (CT k v) k v
forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
key v
value v
newValue
                        Queue k -> State (Store (CT k v) k v) ()
go ((k -> Queue k -> Queue k) -> Queue k -> [k] -> Queue k
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k -> [k] -> Queue k -> Queue k
forall k. Eq k => k -> [k] -> Queue k -> Queue k
`enqueue` []) Queue k
q [k]
bs)

---------------------------------- Suspending ----------------------------------
-- | This scheduler builds keys recursively: to build a key it executes the
-- associated task, discovering its dependencies on the fly, and if one of the
-- dependencies is dirty, the task is suspended until the dependency is rebuilt.
-- It stores the set of keys that have already been built as part of the state
-- to avoid executing the same task twice.
suspending :: forall i k v. Ord k => Scheduler Monad i i k v
suspending :: forall i k v. Ord k => Scheduler Monad i i k v
suspending Rebuilder Monad i k v
rebuilder Tasks Monad k v
tasks k
target Store i k v
store = (Store i k v, Set k) -> Store i k v
forall a b. (a, b) -> a
fst ((Store i k v, Set k) -> Store i k v)
-> (Store i k v, Set k) -> Store i k v
forall a b. (a -> b) -> a -> b
$ State (Store i k v, Set k) v
-> (Store i k v, Set k) -> (Store i k v, Set k)
forall s a. State s a -> s -> s
execState (k -> State (Store i k v, Set k) v
fetch k
target) (Store i k v
store, Set k
forall a. Set a
Set.empty)
  where
    fetch :: k -> State (Store i k v, Set k) v
    fetch :: k -> State (Store i k v, Set k) v
fetch k
key = do
        Set k
done <- ((Store i k v, Set k) -> Set k)
-> StateT (Store i k v, Set k) Identity (Set k)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Store i k v, Set k) -> Set k
forall a b. (a, b) -> b
snd
        case Tasks Monad k v
tasks k
key of
            Just Task Monad k v
task | k
key k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set k
done -> do
                v
value <- ((Store i k v, Set k) -> v) -> State (Store i k v, Set k) v
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key (Store i k v -> v)
-> ((Store i k v, Set k) -> Store i k v)
-> (Store i k v, Set k)
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Store i k v, Set k) -> Store i k v
forall a b. (a, b) -> a
fst)
                let newTask :: Task (MonadState i) k v
                    newTask :: Task (MonadState i) k v
newTask = Rebuilder Monad i k v
rebuilder k
key v
value (k -> f v) -> f v
Task Monad k v
task
                v
newValue <- Task (MonadState i) k v
-> (k -> State (Store i k v, Set k) v)
-> State (Store i k v, Set k) v
forall i k v extra.
Task (MonadState i) k v
-> (k -> State (Store i k v, extra) v)
-> State (Store i k v, extra) v
liftRun (k -> f v) -> f v
Task (MonadState i) k v
newTask k -> State (Store i k v, Set k) v
fetch
                ((Store i k v, Set k) -> (Store i k v, Set k))
-> StateT (Store i k v, Set k) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Store i k v, Set k) -> (Store i k v, Set k))
 -> StateT (Store i k v, Set k) Identity ())
-> ((Store i k v, Set k) -> (Store i k v, Set k))
-> StateT (Store i k v, Set k) Identity ()
forall a b. (a -> b) -> a -> b
$ (Store i k v -> Store i k v)
-> (Set k -> Set k) -> (Store i k v, Set k) -> (Store i k v, Set k)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (k -> v -> v -> Store i k v -> Store i k v
forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
key v
value v
newValue) (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
key)
                v -> State (Store i k v, Set k) v
forall a. a -> StateT (Store i k v, Set k) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue
            Maybe (Task Monad k v)
_ -> ((Store i k v, Set k) -> v) -> State (Store i k v, Set k) v
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key (Store i k v -> v)
-> ((Store i k v, Set k) -> Store i k v)
-> (Store i k v, Set k)
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Store i k v, Set k) -> Store i k v
forall a b. (a, b) -> a
fst) -- fetch the existing value

-- | Run a @Task (MonadState i)@ using a fetch callback operating on a larger
-- state that contains a @Store i k v@ plus some @extra@ information.
liftRun :: Task (MonadState i) k v
        -> (k -> State (Store i k v, extra) v) -> State (Store i k v, extra) v
liftRun :: forall i k v extra.
Task (MonadState i) k v
-> (k -> State (Store i k v, extra) v)
-> State (Store i k v, extra) v
liftRun Task (MonadState i) k v
t k -> State (Store i k v, extra) v
f = Wrap i extra k v v -> State (Store i k v, extra) v
forall i extra k v a.
Wrap i extra k v a -> State (Store i k v, extra) a
unwrap (Wrap i extra k v v -> State (Store i k v, extra) v)
-> Wrap i extra k v v -> State (Store i k v, extra) v
forall a b. (a -> b) -> a -> b
$ (k -> Wrap i extra k v v) -> Wrap i extra k v v
Task (MonadState i) k v
t (State (Store i k v, extra) v -> Wrap i extra k v v
forall i extra k v a.
State (Store i k v, extra) a -> Wrap i extra k v a
Wrap (State (Store i k v, extra) v -> Wrap i extra k v v)
-> (k -> State (Store i k v, extra) v) -> k -> Wrap i extra k v v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> State (Store i k v, extra) v
f)

newtype Wrap i extra k v a = Wrap { forall i extra k v a.
Wrap i extra k v a -> State (Store i k v, extra) a
unwrap :: State (Store i k v, extra) a }
    deriving ((forall a b. (a -> b) -> Wrap i extra k v a -> Wrap i extra k v b)
-> (forall a b. a -> Wrap i extra k v b -> Wrap i extra k v a)
-> Functor (Wrap i extra k v)
forall a b. a -> Wrap i extra k v b -> Wrap i extra k v a
forall a b. (a -> b) -> Wrap i extra k v a -> Wrap i extra k v b
forall i extra k v a b.
a -> Wrap i extra k v b -> Wrap i extra k v a
forall i extra k v a b.
(a -> b) -> Wrap i extra k v a -> Wrap i extra k v b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall i extra k v a b.
(a -> b) -> Wrap i extra k v a -> Wrap i extra k v b
fmap :: forall a b. (a -> b) -> Wrap i extra k v a -> Wrap i extra k v b
$c<$ :: forall i extra k v a b.
a -> Wrap i extra k v b -> Wrap i extra k v a
<$ :: forall a b. a -> Wrap i extra k v b -> Wrap i extra k v a
Functor, Functor (Wrap i extra k v)
Functor (Wrap i extra k v) =>
(forall a. a -> Wrap i extra k v a)
-> (forall a b.
    Wrap i extra k v (a -> b)
    -> Wrap i extra k v a -> Wrap i extra k v b)
-> (forall a b c.
    (a -> b -> c)
    -> Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v c)
-> (forall a b.
    Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b)
-> (forall a b.
    Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v a)
-> Applicative (Wrap i extra k v)
forall a. a -> Wrap i extra k v a
forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v a
forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
forall a b.
Wrap i extra k v (a -> b)
-> Wrap i extra k v a -> Wrap i extra k v b
forall a b c.
(a -> b -> c)
-> Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v c
forall i extra k v. Functor (Wrap i extra k v)
forall i extra k v a. a -> Wrap i extra k v a
forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v a
forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
forall i extra k v a b.
Wrap i extra k v (a -> b)
-> Wrap i extra k v a -> Wrap i extra k v b
forall i extra k v a b c.
(a -> b -> c)
-> Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall i extra k v a. a -> Wrap i extra k v a
pure :: forall a. a -> Wrap i extra k v a
$c<*> :: forall i extra k v a b.
Wrap i extra k v (a -> b)
-> Wrap i extra k v a -> Wrap i extra k v b
<*> :: forall a b.
Wrap i extra k v (a -> b)
-> Wrap i extra k v a -> Wrap i extra k v b
$cliftA2 :: forall i extra k v a b c.
(a -> b -> c)
-> Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v c
liftA2 :: forall a b c.
(a -> b -> c)
-> Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v c
$c*> :: forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
*> :: forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
$c<* :: forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v a
<* :: forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v a
Applicative, Applicative (Wrap i extra k v)
Applicative (Wrap i extra k v) =>
(forall a b.
 Wrap i extra k v a
 -> (a -> Wrap i extra k v b) -> Wrap i extra k v b)
-> (forall a b.
    Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b)
-> (forall a. a -> Wrap i extra k v a)
-> Monad (Wrap i extra k v)
forall a. a -> Wrap i extra k v a
forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
forall a b.
Wrap i extra k v a
-> (a -> Wrap i extra k v b) -> Wrap i extra k v b
forall i extra k v. Applicative (Wrap i extra k v)
forall i extra k v a. a -> Wrap i extra k v a
forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
forall i extra k v a b.
Wrap i extra k v a
-> (a -> Wrap i extra k v b) -> Wrap i extra k v b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall i extra k v a b.
Wrap i extra k v a
-> (a -> Wrap i extra k v b) -> Wrap i extra k v b
>>= :: forall a b.
Wrap i extra k v a
-> (a -> Wrap i extra k v b) -> Wrap i extra k v b
$c>> :: forall i extra k v a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
>> :: forall a b.
Wrap i extra k v a -> Wrap i extra k v b -> Wrap i extra k v b
$creturn :: forall i extra k v a. a -> Wrap i extra k v a
return :: forall a. a -> Wrap i extra k v a
Monad)

instance MonadState i (Wrap i extra k v) where
    get :: Wrap i extra k v i
get   = State (Store i k v, extra) i -> Wrap i extra k v i
forall i extra k v a.
State (Store i k v, extra) a -> Wrap i extra k v a
Wrap (State (Store i k v, extra) i -> Wrap i extra k v i)
-> State (Store i k v, extra) i -> Wrap i extra k v i
forall a b. (a -> b) -> a -> b
$ ((Store i k v, extra) -> i) -> State (Store i k v, extra) i
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Store i k v -> i
forall i k v. Store i k v -> i
getInfo (Store i k v -> i)
-> ((Store i k v, extra) -> Store i k v)
-> (Store i k v, extra)
-> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Store i k v, extra) -> Store i k v
forall a b. (a, b) -> a
fst)
    put :: i -> Wrap i extra k v ()
put i
i = State (Store i k v, extra) () -> Wrap i extra k v ()
forall i extra k v a.
State (Store i k v, extra) a -> Wrap i extra k v a
Wrap (State (Store i k v, extra) () -> Wrap i extra k v ())
-> State (Store i k v, extra) () -> Wrap i extra k v ()
forall a b. (a -> b) -> a -> b
$ ((Store i k v, extra) -> (Store i k v, extra))
-> State (Store i k v, extra) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Store i k v, extra) -> (Store i k v, extra))
 -> State (Store i k v, extra) ())
-> ((Store i k v, extra) -> (Store i k v, extra))
-> State (Store i k v, extra) ()
forall a b. (a -> b) -> a -> b
$ (Store i k v -> Store i k v)
-> (Store i k v, extra) -> (Store i k v, extra)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (i -> Store i k v -> Store i k v
forall i k v. i -> Store i k v -> Store i k v
putInfo i
i)

-- | An incorrect scheduler that builds the target key without respecting its
-- dependencies. It produces the correct result only if all dependencies of the
-- target key are up to date.
independent :: forall i k v. Eq k => Scheduler Monad i i k v
independent :: forall i k v. Eq k => Scheduler Monad i i k v
independent Rebuilder Monad i k v
rebuilder Tasks Monad k v
tasks k
target Store i k v
store = case Tasks Monad k v
tasks k
target of
    Maybe (Task Monad k v)
Nothing -> Store i k v
store
    Just Task Monad k v
task ->
        let value :: v
value   = k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
target Store i k v
store
            newTask :: (k -> StateT i Identity v) -> StateT i Identity v
newTask = Rebuilder Monad i k v
rebuilder k
target v
value (k -> f v) -> f v
Task Monad k v
task
            fetch :: k -> State i v
            fetch :: k -> StateT i Identity v
fetch k
k = v -> StateT i Identity v
forall a. a -> StateT i Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> Store i k v -> v
forall k i v. k -> Store i k v -> v
getValue k
k Store i k v
store)
            (v
newValue, i
newInfo) = StateT i Identity v -> i -> (v, i)
forall s a. State s a -> s -> (a, s)
runState ((k -> StateT i Identity v) -> StateT i Identity v
newTask k -> StateT i Identity v
fetch) (Store i k v -> i
forall i k v. Store i k v -> i
getInfo Store i k v
store)
        in i -> Store i k v -> Store i k v
forall i k v. i -> Store i k v -> Store i k v
putInfo i
newInfo (Store i k v -> Store i k v) -> Store i k v -> Store i k v
forall a b. (a -> b) -> a -> b
$ k -> v -> v -> Store i k v -> Store i k v
forall k v i. Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue k
target v
value v
newValue Store i k v
store