#if __GLASGOW_HASKELL__ >= 708
#else
#endif
module
Control.Arrow.Machine.Utils
(
hold,
dHold,
accum,
dAccum,
edge,
switch,
dSwitch,
rSwitch,
drSwitch,
kSwitch,
dkSwitch,
pSwitch,
pSwitchB,
rpSwitch,
rpSwitchB,
tee,
gather,
sample,
source,
fork,
filter,
echo,
anytime,
par,
parB,
now,
onEnd,
readerProc
)
where
import Prelude hiding (filter)
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.Applicative
import Control.Arrow.Transformer.Reader (ArrowAddReader(..))
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 = proc x ->
do
rec
ev <- unsafeExhaust (arr judge) -< (prv, x)
prv <- dHold Nothing -< Just x <$ ev
returnA -< ev
where
judge (prv, x) = if prv == Just x then Nothing else Just x
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)
readerProc ::
(ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>
ProcessA a b c ->
ProcessA a' (b, r) c
readerProc pa = arr swap >>> fitW snd (\ar -> arr swap >>> elimReader ar) pa
where
swap :: (a, b) -> (b, a)
swap ~(a, b) = (b, a)