{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
module Build.Scheduler (
topological,
restarting, Chain,
restarting2,
suspending,
independent
) where
import Control.Monad.State
import Control.Monad.Trans.Except
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
liftStore :: State i a -> State (Store i k v) a
liftStore x = do
(a, newInfo) <- gets (runState x . getInfo)
modify (putInfo newInfo)
return a
liftInfo :: State (Store i k v) a -> State (Store (i, j) k v) a
liftInfo x = do
store <- get
let (a, newStore) = runState x (mapInfo fst store)
put $ mapInfo (, snd $ getInfo $ store) newStore
return a
updateValue :: Eq k => k -> v -> v -> Store i k v -> Store i k v
updateValue key _value newValue = putValue key newValue
topological :: forall i k v. Ord k => Scheduler Applicative i i k v
topological rebuilder tasks target = execState $ mapM_ build order
where
build :: k -> State (Store i k v) ()
build key = case tasks key of
Nothing -> return ()
Just task -> do
store <- get
let value = getValue key store
newTask :: Task (MonadState i) k v
newTask = rebuilder key value task
fetch :: k -> State i v
fetch k = return (getValue k store)
newValue <- liftStore (run newTask fetch)
modify $ updateValue key value newValue
order = case topSort (graph deps target) of
Nothing -> error "Cannot build tasks with cyclic dependencies"
Just xs -> xs
deps k = case tasks k of { Nothing -> []; Just task -> dependencies task }
try :: Task (MonadState i) k v -> Task (MonadState i) k (Either e v)
try task = Task $ \fetch -> runExceptT $ run task (ExceptT . fetch)
type Chain k = [k]
restarting :: forall ir k v. Ord k => Scheduler Monad (ir, Chain k) ir k v
restarting rebuilder tasks target = execState $ do
chain <- gets (snd . getInfo)
newChain <- liftInfo $ go Set.empty $ chain ++ [target | target `notElem` chain]
modify . mapInfo $ \(ir, _) -> (ir, newChain)
where
go :: Set k -> Chain k -> State (Store ir k v) (Chain k)
go _ [] = return []
go done (key:ks) = case tasks key of
Nothing -> (key :) <$> go (Set.insert key done) ks
Just task -> do
store <- get
let value = getValue key store
newTask :: Task (MonadState ir) k (Either k v)
newTask = try $ rebuilder key value task
fetch :: k -> State ir (Either k v)
fetch k | k `Set.member` done = return $ Right (getValue k store)
| otherwise = return $ Left k
result <- liftStore (run newTask fetch)
case result of
Left dep -> go done $ dep : filter (/= dep) ks ++ [key]
Right newValue -> do
modify $ updateValue key value newValue
(key :) <$> go (Set.insert key 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)
restarting2 :: forall k v. (Hashable v, Eq k) => Scheduler Monad (CT k v) (CT k v) k v
restarting2 rebuilder tasks target = execState $ go (enqueue target [] mempty)
where
go :: Queue k -> State (Store (CT k v) k v) ()
go queue = case dequeue queue of
Nothing -> return ()
Just (key, bs, q) -> case tasks key of
Nothing -> return ()
Just task -> do
store <- get
let value = getValue key store
upToDate k = isInput tasks k || not (isDirtyCT k store)
newTask :: Task (MonadState (CT k v)) k (Either k v)
newTask = try $ rebuilder key value task
fetch :: k -> State (CT k v) (Either k v)
fetch k | upToDate k = return (Right (getValue k store))
| otherwise = return (Left k)
result <- liftStore (run newTask fetch)
case result of
Left dep -> go (enqueue dep (key:bs) q)
Right newValue -> do
modify $ updateValue key value newValue
go (foldr (\b -> enqueue b []) q bs)
suspending :: forall i k v. Ord k => Scheduler Monad i i k v
suspending rebuilder tasks target store = fst $ execState (fetch target) (store, Set.empty)
where
fetch :: k -> State (Store i k v, Set k) v
fetch key = do
done <- gets snd
case tasks key of
Just task | key `Set.notMember` done -> do
value <- gets (getValue key . fst)
let newTask :: Task (MonadState i) k v
newTask = rebuilder key value task
newValue <- liftRun newTask fetch
modify $ \(s, d) -> (updateValue key value newValue s, Set.insert key d)
return newValue
_ -> gets (getValue key . fst)
liftRun :: Task (MonadState i) k v
-> (k -> State (Store i k v, extra) v) -> State (Store i k v, extra) v
liftRun t f = unwrap $ run t (Wrap . f)
newtype Wrap i extra k v a = Wrap { unwrap :: State (Store i k v, extra) a }
deriving (Functor, Applicative, Monad)
instance MonadState i (Wrap i extra k v) where
get = Wrap $ gets (getInfo . fst)
put i = Wrap $ modify $ \(store, extra) -> (putInfo i store, extra)
independent :: forall i k v. Eq k => Scheduler Monad i i k v
independent rebuilder tasks target store = case tasks target of
Nothing -> store
Just task ->
let value = getValue target store
newTask = rebuilder target value task
fetch :: k -> State i v
fetch k = return (getValue k store)
(newValue, newInfo) = runState (run newTask fetch) (getInfo store)
in putInfo newInfo $ updateValue target value newValue store