module Control.Wire.Trans.Sample
(
hold,
holdWith,
sample,
swallow
)
where
import Control.Arrow
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types
hold :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a b
hold (WPure f) =
mkPure $ \x' ->
let (mx, w) = f x' in
case mx of
Left ex -> (Left ex, hold w)
Right x -> (Right x, holdWith x w)
hold (WGen c) =
mkGen $ proc x' -> do
(mx, w) <- c -< x'
returnA -<
case mx of
Left ex -> (Left ex, hold w)
Right x -> (Right x, holdWith x w)
holdWith :: Arrow (>~) => b -> Wire e (>~) a b -> Wire e (>~) a b
holdWith x0 (WPure f) =
mkPure $ \x' ->
let (mx, w) = f x' in
case mx of
Left _ -> (Right x0, holdWith x0 w)
Right x -> (Right x, holdWith x w)
holdWith x0 (WGen c) =
mkGen $ proc x' -> do
(mx, w) <- c -< x'
returnA -<
case mx of
Left _ -> (Right x0, holdWith x0 w)
Right x -> (Right x, holdWith x w)
sample ::
forall a b e t (>~).
(ArrowChoice (>~), ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) a b
-> Wire e (>~) (a, t) b
sample w' =
mkGen $ proc (x', _) -> do
t <- arrTime -< ()
(mx, w) <- toGen w' -< x'
returnA -< (mx, sample' t mx w)
where
sample' :: t -> Either e b -> Wire e (>~) a b -> Wire e (>~) (a, t) b
sample' t' mx0 w' =
mkGen $ proc (x', dt) -> do
t <- arrTime -< ()
if t t' < dt
then returnA -< (mx0, sample' t' mx0 w')
else do
(mx, w) <- toGen w' -< x'
returnA -< (mx, sample' t mx w)
swallow :: ArrowChoice (>~) => Wire e (>~) a b -> Wire e (>~) a b
swallow (WPure f) =
mkPure $ \x' ->
case f x' of
(Left ex, w) -> (Left ex, swallow w)
(Right x, _) -> (Right x, constant x)
swallow (WGen c) =
mkGen $ proc x' -> do
(mx, w) <- c -< x'
case mx of
Left ex -> returnA -< (Left ex, swallow w)
Right x -> returnA -< (Right x, constant x)