module Control.Wire.Trans.Event
(
eitherE,
(<||>),
hold,
hold_,
holdFor,
holdForI,
(<!>),
event,
exhibit,
gotEvent,
notE
)
where
import Control.Arrow
import Control.Category
import Control.Wire.Types
import Control.Wire.Wire
import Data.Monoid hiding ((<>))
import Data.Semigroup
import Prelude hiding ((.), id)
eitherE ::
(Monad m, Monoid e)
=> (b1 -> b)
-> (b2 -> b)
-> (b1 -> b2 -> b)
-> Wire e m a b1
-> Wire e m a b2
-> Wire e m a b
eitherE left right both = eitherE'
where
eitherE' w1' w2' =
mkGen $ \dt x' -> do
(mx1, w1) <- stepWire w1' dt x'
(mx2, w2) <- stepWire w2' dt x'
let res =
case (mx1, mx2) of
(Left ex1, Left ex2) -> Left (mappend ex1 ex2)
(Right x1, Right x2) -> Right (both x1 x2)
(Right x1, _) -> Right (left x1)
(_, Right x2) -> Right (right x2)
return (res, eitherE' w1 w2)
(<||>) ::
(Monad m, Monoid e, Semigroup b)
=> Wire e m a b
-> Wire e m a b
-> Wire e m a b
(<||>) = eitherE id id (<>)
(<!>) :: (Monad m) => Wire e m a b -> e -> Wire e m a b
w <!> ex = mapOutput (either (Left . const ex) Right) w
event :: (Monad m) => Wire e m a b -> Wire e m a (Maybe b)
event = mapOutput (Right . either (const Nothing) Just)
exhibit :: (Monad m) => Wire e m a b -> Wire e m a (Either e b)
exhibit = mapOutput Right
gotEvent :: (Monad m) => Wire e m a b -> Wire e m a Bool
gotEvent = mapOutput (Right . either (const False) (const True))
hold :: (Monad m) => b -> Wire e m a b -> Wire e m a b
hold x0 w' =
mkGen $ \dt x' -> do
(mx, w) <- stepWire w' dt x'
case mx of
Left _ -> return (Right x0, hold x0 w)
Right x -> return (Right x, hold x w)
hold_ :: (Monad m) => Wire e m a b -> Wire e m a b
hold_ w' =
mkGen $ \dt x' -> do
(mx, w) <- stepWire w' dt x'
return (mx, either (const hold_) hold mx w)
holdFor :: (Monad m) => Time -> Wire e m a b -> Wire e m a b
holdFor t0 w = hold' . exhibit w
where
hold' =
mkPure $ \_ mx ->
case mx of
Left _ -> (mx, hold')
Right x -> (mx, hold'' t0 x)
hold'' t' x' =
mkPure $ \dt mx ->
let t = t' dt in
case mx of
Left _
| t > 0 -> (Right x', hold'' t x')
| otherwise -> (mx, hold')
Right x -> (mx, hold'' t0 x)
holdForI :: (Monad m) => Time -> Wire e m a b -> Wire e m a b
holdForI t0 w = hold' . exhibit w
where
hold' = mkPure $ \_ -> id &&& either (const hold') (hold'' t0)
hold'' t x'
| t <= 0 = hold'
| otherwise =
mkPure $ \_ mx ->
case mx of
Left _ -> (Right x', hold'' (t 1) x')
Right x -> (mx, hold'' t0 x)
notE :: (Monad m, Monoid e) => Event e m a -> Event e m a
notE w' =
mkGen $ \dt x' -> do
(mx, w) <- stepWire w' dt x'
return (either (const $ Right x') (const $ Left mempty) mx, notE w)