{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications, GeneralizedNewtypeDeriving #-}
module Build.Scheduler (
topological,
reordering, Chain,
restarting,
recursive,
independent
) where
import Control.Monad.State
import Control.Monad.Trans.Except
import Data.Set (Set)
import Build
import Build.Task
import Build.Task.Monad
import Build.Task.Wrapped
import Build.Store
import Build.Rebuilder
import Build.Utilities
import qualified Data.Set as Set
import qualified Build.Task.Applicative as A
updateValue :: Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue key _value newValue = putValue key newValue
topological :: Ord k => Rebuilder Applicative i k v -> Build Applicative i k v
topological rebuilder tasks key = execState $ forM_ chain $ \k ->
case tasks k of
Nothing -> return ()
Just task -> do
value <- gets (getValue k)
let newTask = rebuilder k value (unwrap @Applicative task)
newFetch :: k -> StateT i (State (Store i k v)) v
newFetch = lift . gets . getValue
info <- gets getInfo
(newValue, newInfo) <- runStateT (newTask newFetch) info
modify $ putInfo newInfo . updateValue k value newValue
where
deps = maybe [] (\t -> A.dependencies $ unwrap @Applicative t) . tasks
chain = case topSort (graph deps key) of
Nothing -> error "Cannot build tasks with cyclic dependencies"
Just xs -> xs
try :: Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try task fetch = runExceptT $ task (ExceptT . fetch)
type Chain k = [k]
reordering :: forall i k v. Ord k => Rebuilder Monad i k v -> Build Monad (i, Chain k) k v
reordering rebuilder tasks key = execState $ do
chain <- snd . getInfo <$> get
newChain <- go Set.empty $ chain ++ [key | key `notElem` chain]
modify . mapInfo $ \(i, _) -> (i, newChain)
where
go :: Set k -> Chain k -> State (Store (i, Chain k) k v) (Chain k)
go _ [] = return []
go done (k:ks) = case tasks k of
Nothing -> (k :) <$> go (Set.insert k done) ks
Just task -> do
store <- get
let value = getValue k store
newTask :: Task (MonadState i) k v
newTask = rebuilder k value (unwrap @Monad task)
newFetch :: k -> State i (Either k v)
newFetch k | k `Set.member` done = return $ Right (getValue k store)
| otherwise = return $ Left k
case runState (try newTask newFetch) (fst $ getInfo store) of
(Left dep, _) -> go done $ [ dep | dep `notElem` ks ] ++ ks ++ [k]
(Right newValue, newInfo) -> do
modify $ putInfo (newInfo, []) . updateValue k value newValue
(k :) <$> go (Set.insert k done) ks
type Queue k = [(k, [k])]
enqueue :: Eq k => k -> [k] -> Queue k -> Queue k
enqueue key blocked [] = [(key, blocked)]
enqueue key blocked ((k, bs):q)
| k == key = (k, blocked ++ bs) : q
| otherwise = (k, bs) : enqueue key blocked q
dequeue :: Queue k -> Maybe (k, [k], Queue k)
dequeue [] = Nothing
dequeue ((k, bs):q) = Just (k, bs, q)
type IsDirty i k v = k -> Store i k v -> Bool
restarting :: forall i k v. Eq k => IsDirty i k v -> Rebuilder Monad i k v -> Build Monad i k v
restarting isDirty rebuilder tasks key = execState $ go (enqueue key [] mempty)
where
go :: Queue k -> State (Store i k v) ()
go queue = case dequeue queue of
Nothing -> return ()
Just (k, bs, q) -> case tasks k of
Nothing -> return ()
Just task -> do
store <- get
let value = getValue k store
upToDate k = isInput tasks k || not (isDirty k store)
newTask :: Task (MonadState i) k v
newTask = rebuilder k value (unwrap @Monad task)
newFetch :: k -> State i (Either k v)
newFetch k | upToDate k = return (Right (getValue k store))
| otherwise = return (Left k)
case runState (try newTask newFetch) (getInfo store) of
(Left dirtyDependency, _) -> go (enqueue dirtyDependency (k:bs) q)
(Right newValue, newInfo) -> do
modify $ putInfo newInfo . updateValue k value newValue
go (foldr (\b -> enqueue b []) q bs)
recursive :: forall i k v. Ord k => Rebuilder Monad i k v -> Build Monad i k v
recursive rebuilder tasks key store = fst $ execState (fetch key) (store, Set.empty)
where
fetch :: k -> State (Store i k v, Set k) v
fetch key = case tasks key of
Nothing -> gets (getValue key . fst)
Just task -> do
done <- gets snd
when (key `Set.notMember` done) $ do
value <- gets (getValue key . fst)
let newTask = rebuilder key value (unwrap @Monad task)
newFetch :: k -> StateT i (State (Store i k v, Set k)) v
newFetch = lift . fetch
info <- gets (getInfo . fst)
(newValue, newInfo) <- runStateT (newTask newFetch) info
modify $ \(s, done) ->
( putInfo newInfo $ updateValue key value newValue s
, Set.insert key done )
gets (getValue key . fst)
independent :: forall i k v. Eq k => Rebuilder Monad i k v -> Build Monad i k v
independent rebuilder tasks key store = case tasks key of
Nothing -> store
Just task ->
let value = getValue key store
newTask = rebuilder key value (unwrap @Monad task)
newFetch :: k -> State i v
newFetch k = return (getValue k store)
(newValue, newInfo) = runState (newTask newFetch) (getInfo store)
in putInfo newInfo $ updateValue key value newValue store