{-# LANGUAGE Arrows #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Control.Arrow.Schedule
( RunSched
, runTick
, runTicksTo
, getInput
, mkOutput
, tickTask
, module Data.Schedule
)
where
import Control.Arrow
import Data.Functor.Identity (Identity (..))
import Data.Maybe (fromMaybe)
import Data.Schedule
import Data.Schedule.Internal
whileJustA :: (ArrowChoice a, Monoid o) => a i (Maybe o) -> a i o
whileJustA act = (, mempty) ^>> go
where
go = proc (i, rr) -> do
r' <- act -< i
case r' of
Nothing -> returnA -< rr
Just r -> go -< (i, rr <> r)
type RunSched t a = forall i o . ((i, Schedule t) -> (o, Schedule t)) -> a i o
runTick
:: (ArrowChoice a, Monoid o) => RunSched t a -> a (Tick, t) o -> a Tick o
runTick runS runTickTask = whileJustA $ proc tick -> do
r' <- runS (stA popOrTick) -< ()
case r' of
Nothing -> returnA -< Nothing
Just (t, p) -> do
() <- runS (imodA acquireTask) -< (t, p)
r <- runTickTask -< (tick, p)
() <- runS (imodA releaseTask) -< t
returnA -< Just r
runTicksTo
:: (ArrowChoice a, Monoid o) => RunSched t a -> a (Tick, t) o -> a Tick o
runTicksTo runS runTask = whileJustA $ proc tick -> do
tick' <- runS (getA tickNow) -< ()
if tick' >= tick
then returnA -< Nothing
else Just ^<< runTick runS runTask -< tick
getInput
:: (Arrow a)
=> RunSched t a
-> a TickDelta (Either Tick i)
-> a i' (Either Tick i)
getInput runS getTimedInput =
runS (getA ticksToIdle) >>> fromMaybe maxBound ^>> getTimedInput
mkOutput
:: (ArrowChoice a, Monoid o)
=> RunSched t a
-> a (Tick, t) o
-> a i o
-> a (Either Tick i) o
mkOutput runS runTask runInput = runTicksTo runS runTask ||| runInput
tickTask
:: (ArrowChoice a, ArrowApply a, Monoid o)
=> RunSched t a
-> (forall f . Applicative f => (Tick -> f (Tick, t)) -> i -> f it)
-> a it o
-> a i o
tickTask runS prism runTaskOr = proc input -> case prism Left input of
Right it -> runTaskOr -< it
Left tick -> runTicksTo runS (runTaskOr <<^ inputWithTask) -<< tick
where inputWithTask tk = runIdentity (prism (const (pure tk)) input)