module
Control.Arrow.Machine.Utils
(
hold,
dHold,
accum,
dAccum,
edge,
passRecent,
withRecent,
switch,
dSwitch,
rSwitch,
drSwitch,
kSwitch,
dkSwitch,
pSwitch,
pSwitchB,
rpSwitch,
rpSwitchB,
peekState,
encloseState,
tee,
gather,
sample,
source,
fork,
filter,
echo,
anytime,
par,
parB,
now,
onEnd,
cycleDelay
)
where
import Prelude hiding (filter)
import Data.Maybe (fromMaybe)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Foldable as Fd
import qualified Control.Category as Cat
import Control.Monad.Trans
import Control.Monad.State
import Control.Arrow
import Control.Arrow.Operations (ArrowState(..))
import Control.Arrow.Transformer.State (ArrowAddState(..), StateArrow())
import Control.Applicative
import Control.Arrow.Machine.ArrowUtil
import Control.Arrow.Machine.Types
hold ::
ArrowApply a => b -> ProcessA a (Event b) b
hold old = proc evx ->
do
rSwitch (pure old) -< ((), pure <$> evx)
dHold ::
ArrowApply a => b -> ProcessA a (Event b) b
dHold old = proc evx ->
do
drSwitch (pure old) -< ((), pure <$> evx)
accum ::
ArrowApply a => b -> ProcessA a (Event (b->b)) b
accum x = switch (pure x &&& arr (($x)<$>)) accum'
where
accum' y = dSwitch (pure y &&& Cat.id) (const (accum y))
dAccum ::
ArrowApply a => b -> ProcessA a (Event (b->b)) b
dAccum x = dSwitch (pure x &&& arr (($x)<$>)) dAccum
edge ::
(ArrowApply a, Eq b) =>
ProcessA a b (Event b)
edge = encloseState (unsafeExhaust impl) Nothing
where
impl ::
(ArrowApply a, Eq b) =>
StateArrow (Maybe b) a b (Maybe b)
impl = proc x ->
do
mprv <- fetch -< ()
store -< Just x
returnA -<
case mprv
of
Just prv -> if prv == x then Nothing else Just x
Nothing -> Just x
infixr 9 `passRecent`
passRecent ::
(ArrowApply a, Occasional o) =>
ProcessA a (AS e) (Event b) ->
ProcessA a (e, AS b) o ->
ProcessA a (AS e) o
passRecent af ag = proc ase ->
do
evx <- af -< ase
mvx <- hold Nothing -< Just <$> evx
case mvx of
Just x -> ag -< (fromAS ase, toAS x)
_ -> returnA -< noEvent
withRecent ::
(ArrowApply a, Occasional o) =>
ProcessA a (e, AS b) o ->
ProcessA a (e, AS (Event b)) o
withRecent af = proc (e, asevx) ->
do
mvx <- hold Nothing -< Just <$> fromAS asevx
case mvx of
Just x -> af -< (e, toAS x)
_ -> returnA -< noEvent
peekState ::
(ArrowApply a, ArrowState s a) =>
ProcessA a e s
peekState = unsafeSteady fetch
exposeState ::
(ArrowApply a, ArrowApply a', ArrowAddState s a a') =>
ProcessA a b c ->
ProcessA a' (b, s) (c, s)
exposeState = fitEx es
where
es f = proc (p, (x, s)) ->
do
((q, y), s') <- elimState f -< ((p, x), s)
returnA -< (q, (y, s'))
encloseState ::
(ArrowApply a, ArrowApply a', ArrowAddState s a a') =>
ProcessA a b c ->
s ->
ProcessA a' b c
encloseState pa s = loop' s (exposeState pa)
tee ::
ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2))
tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2]
sample ::
ArrowApply a =>
ProcessA a (Event b1, Event b2) [b1]
sample = undefined
gather ::
(ArrowApply a, Fd.Foldable f) =>
ProcessA a (f (Event b)) (Event b)
gather = arr (Fd.foldMap $ fmap singleton) >>> fork
where
singleton x = x NonEmpty.:| []
source ::
(ArrowApply a, Fd.Foldable f) =>
f c -> ProcessA a (Event b) (Event c)
source l = construct $ Fd.mapM_ yd l
where
yd x = await >> yield x
fork ::
(ArrowApply a, Fd.Foldable f) =>
ProcessA a (Event (f b)) (Event b)
fork = repeatedly $
await >>= Fd.mapM_ yield
anytime ::
ArrowApply a =>
a b c ->
ProcessA a (Event b) (Event c)
anytime action = repeatedlyT (ary0 unArrowMonad) $
do
x <- await
ret <- lift $ arrowMonad action x
yield ret
filter ::
ArrowApply a =>
a b Bool ->
ProcessA a (Event b) (Event b)
filter cond = repeatedlyT (ary0 unArrowMonad) $
do
x <- await
b <- lift $ arrowMonad cond x
if b then yield x else return ()
echo ::
ArrowApply a =>
ProcessA a (Event b) (Event b)
echo = filter (arr (const True))
now ::
ArrowApply a =>
ProcessA a b (Event ())
now = arr (const noEvent) >>> go
where
go = construct $
yield () >> forever await
onEnd ::
(ArrowApply a, Occasional' b) =>
ProcessA a b (Event ())
onEnd = arr collapse >>> go
where
go = repeatedly $
await `catchP` (yield () >> stop)
cycleDelay ::
ArrowApply a => ProcessA a b b
cycleDelay =
encloseState impl (Nothing, Nothing)
where
impl :: ArrowApply a => ProcessA (StateArrow (Maybe b, Maybe b) a) b b
impl = proc x ->
do
(_, stored) <- peekState -< ()
unsafeExhaust (app >>> arr (const Nothing)) -< appStore stored
(current, _) <- peekState -< ()
let x0 = fromMaybe x current
unsafeSteady store -< (Just x0, Just x)
returnA -< x0
appStore (Just x) = (proc _ -> store -< (Just x, Nothing), ())
appStore _ = (Cat.id, ())