{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Control.Monad.Schedule
( RunSched
, runTick
, runTicksTo
, getInput
, mkOutput
, tickTask
, module Data.Schedule
)
where
import Control.Monad.Extra (whenMaybe)
import Data.Either (either)
import Data.Functor.Identity (Identity (..))
import Data.Maybe (fromMaybe)
import Data.Schedule
import Data.Schedule.Internal
type RunSched t m = forall a . (Schedule t -> (a, Schedule t)) -> m a
runTick :: (Monad m, Monoid a) => RunSched t m -> (t -> m a) -> m a
runTick runS runTickTask = whileJustM $ do
runS popOrTick >>= \case
Nothing -> pure Nothing
Just (t, p) -> do
runS $ modST $ acquireTask (t, p)
r <- runTickTask p
runS $ modST $ releaseTask t
pure (Just r)
runTicksTo
:: (Monad m, Monoid a) => RunSched t m -> (Tick -> t -> m a) -> Tick -> m a
runTicksTo runS runTask tick = whileJustM $ do
tick' <- runS $ getST tickNow
whenMaybe (tick' < tick) $ runTick runS $ runTask tick
getInput
:: (Monad m)
=> RunSched t m
-> (TickDelta -> m (Either Tick i))
-> m (Either Tick i)
getInput runS getTimedInput = do
d <- runS $ getST ticksToIdle
getTimedInput (fromMaybe maxBound d)
mkOutput
:: (Monad m, Monoid a)
=> RunSched t m
-> (Tick -> t -> m a)
-> (i -> m a)
-> (Either Tick i -> m a)
mkOutput runS runTask runInput = runTicksTo runS runTask `either` runInput
tickTask
:: (Monad m, Monoid a)
=> RunSched t m
-> (forall f . Applicative f => (Tick -> f (Tick, t)) -> i -> f it)
-> (it -> m a)
-> (i -> m a)
tickTask runS prism runTaskOr input = case prism Left input of
Right it -> runTaskOr it
Left tick -> runTicksTo runS (fmap runTaskOr . inputWithTask) tick
where inputWithTask t k = runIdentity (prism (const (pure (t, k))) input)