module
Control.Arrow.Machine.Misc.Discrete
(
T(),
updates,
value,
arr,
arr2,
arr3,
arr4,
arr5,
constant,
hold,
accum,
fromEq,
edge,
asUpdater,
Alg
)
where
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow hiding (arr)
import Control.Applicative
import qualified Control.Arrow as Arr
import qualified Control.Arrow.Machine as P
import Data.Monoid (mconcat, mappend)
data T a = T {
updates :: (P.Event ()),
value :: a
}
makeT ::
ArrowApply a =>
P.ProcessA a (P.Event (), b) (T b)
makeT = Arr.arr $ uncurry T
arr ::
ArrowApply a =>
(b->c) ->
P.ProcessA a (T b) (T c)
arr f =
Arr.arr $ \(T ev x) ->
T ev (f x)
arr2 ::
ArrowApply a =>
(b1->b2->c) ->
P.ProcessA a (T b1, T b2) (T c)
arr2 f =
Arr.arr $ \(T ev1 x1, T ev2 x2) ->
T (mconcat [ev1, ev2]) (f x1 x2)
arr3 ::
ArrowApply a =>
(b1->b2->b3->c) ->
P.ProcessA a (T b1, T b2, T b3) (T c)
arr3 f =
Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3) ->
T (mconcat [ev1, ev2, ev3]) (f x1 x2 x3)
arr4 ::
ArrowApply a =>
(b1->b2->b3->b4->c) ->
P.ProcessA a (T b1, T b2, T b3, T b4) (T c)
arr4 f =
Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4) ->
T (mconcat [ev1, ev2, ev3, ev4]) (f x1 x2 x3 x4)
arr5 ::
ArrowApply a =>
(b1->b2->b3->b4->b5->c) ->
P.ProcessA a (T b1, T b2, T b3, T b4, T b5) (T c)
arr5 f =
Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4, T ev5 x5) ->
T (mconcat [ev1, ev2, ev3, ev4, ev5]) (f x1 x2 x3 x4 x5)
constant::
ArrowApply a =>
c ->
P.ProcessA a b (T c)
constant x =
(P.now &&& Arr.arr (const x)) >>> makeT
onUpdate ::
ArrowApply a =>
P.ProcessA a (P.Event b) (P.Event ())
onUpdate = proc ev ->
do
n <- P.now -< ()
returnA -< n `mappend` P.collapse ev
hold ::
ArrowApply a =>
b ->
P.ProcessA a (P.Event b) (T b)
hold i =
(onUpdate &&& P.hold i) >>> makeT
accum ::
ArrowApply a =>
b ->
P.ProcessA a (P.Event (b->b)) (T b)
accum i =
(onUpdate &&& P.accum i) >>> makeT
fromEq ::
(ArrowApply a, Eq b) =>
P.ProcessA a b (T b)
fromEq = proc x ->
do
ev <- P.edge -< x
returnA -< T (P.collapse ev) x
edge ::
ArrowApply a =>
P.ProcessA a (T b) (P.Event b)
edge = Arr.arr $ \(T ev x) -> x <$ ev
asUpdater ::
ArrowApply a =>
a b c ->
P.ProcessA a (T b) (P.Event c)
asUpdater ar = edge >>> P.anytime ar
newtype Alg a i o = Alg { eval :: P.ProcessA a i (T o) }
instance
ArrowApply a => Functor (Alg a i)
where
fmap f alg = Alg $ eval alg >>> arr f
instance
ArrowApply a => Applicative (Alg a i)
where
pure = Alg . constant
af <*> aa = Alg $ (eval af &&& eval aa) >>> arr2 ($)