#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,
source,
blockingSource,
interleave,
blocking,
tee,
gather,
fork,
filter,
echo,
anytime,
par,
parB,
oneshot,
now,
onEnd,
#if defined(MIN_VERSION_arrows)
readerProc
#endif
)
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
#if defined(MIN_VERSION_arrows)
import Control.Arrow.Transformer.Reader (ArrowAddReader(..))
#endif
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
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
blockingSource ::
(ArrowApply a, Fd.Foldable f) =>
f c -> ProcessA a () (Event c)
blockingSource l = pure noEvent >>> construct (Fd.mapM_ yield l)
interleave ::
ArrowApply a =>
ProcessA a () (Event c) ->
ProcessA a (Event b) (Event c)
interleave bs0 = sweep1 (pure () >>> bs0)
where
waiting bs r =
dSwitch
(handler bs r)
sweep1
sweep1 bs =
kSwitch
bs
(arr snd)
waiting
handler bs r = proc ev ->
do
ev' <- splitter bs r -< ev
returnA -< (filterJust (fst <$> ev'), snd <$> ev')
splitter bs r =
construct $
do
_ <- await
yield (Just r, bs)
`catchP`
yield (Nothing, bs >>> muted)
blocking ::
ArrowApply a =>
ProcessA a (Event ()) (Event c) ->
ProcessA a () (Event c)
blocking is = dSwitch (blockingSource (repeat ()) >>> is >>> (Cat.id &&& onEnd)) (const stopped)
tee ::
ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2))
tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2]
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.:| []
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))
oneshot ::
ArrowApply a =>
c ->
ProcessA a b (Event c)
oneshot x = arr (const noEvent) >>> go
where
go = construct $
yield x >> forever await
now ::
ArrowApply a =>
ProcessA a b (Event ())
now = oneshot ()
onEnd ::
(ArrowApply a, Occasional' b) =>
ProcessA a b (Event ())
onEnd = arr collapse >>> go
where
go = repeatedly $
await `catchP` (yield () >> stop)
#if defined(MIN_VERSION_arrows)
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)
#endif