module Control.Varying.Event (
Event(..),
toMaybe,
isEvent,
latchWith,
orE,
tagOn,
tagM,
--ringM,
use,
onTrue,
onJust,
onUnique,
onWhen,
toEvent,
collect,
collectWith,
hold,
holdWith,
startingWith,
startWith,
between,
until,
after,
beforeWith,
beforeOne,
before,
filterE,
takeE,
once,
always,
never,
andThen,
andThenWith,
andThenE,
switchByMode,
onlyWhen,
onlyWhenE,
combineWith,
combine
) where
import Prelude hiding (until)
import Control.Varying.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
toMaybe :: Event a -> Maybe a
toMaybe (Event a) = Just a
toMaybe _ = Nothing
isEvent :: Event a -> Bool
isEvent (Event _) = True
isEvent _ = False
latchWith :: (Applicative m, Monad m)
=> (b -> c -> d) -> Var m a (Event b) -> Var m a (Event c)
-> Var m a (Event d)
latchWith f vb vc = latchWith' (NoEvent, vb) vc
where latchWith' (eb, vb') vc' =
Var $ \a -> do (eb', vb'') <- runVar vb' a
(ec', vc'') <- runVar vc' a
let eb'' = eb' <|> eb
return $ ( f <$> eb'' <*> ec'
, latchWith' (eb'', vb'') vc''
)
orE :: (Applicative m, Monad m) => Var m a b -> Var m a (Event b) -> Var m a b
orE y ye = Var $ \a -> do
(b, y') <- runVar y a
(e, ye') <- runVar ye a
return $ case e of
NoEvent -> (b, orE y' ye')
Event b' -> (b', orE y' ye')
tagOn :: (Applicative m, Monad m)
=> Var m a b -> Var m a (Event c) -> Var m a (Event b)
tagOn vb ve = (<$) <$> vb <*> ve
tagM :: (Applicative m, Monad m)
=> (b -> m c) -> Var m a (Event b) -> Var m a (Event c)
tagM f vb = Var $ \a -> do
(eb, vb') <- runVar vb a
case eb of
Event b -> do c <- f b
return (Event c, tagM f vb')
NoEvent -> return (NoEvent, tagM f vb')
use :: (Functor f, Functor e) => a -> f (e b) -> f (e a)
use a v = (a <$) <$> v
onTrue :: (Applicative m, Monad m) => Var m Bool (Event ())
onTrue = var $ \b -> if b then Event () else NoEvent
onJust :: (Applicative m, Monad m) => Var m (Maybe a) (Event a)
onJust = var $ \ma -> case ma of
Nothing -> NoEvent
Just a -> Event a
onUnique :: (Applicative m, Monad m, Eq a) => Var m a (Event a)
onUnique = Var $ \a -> return (Event a, trigger a)
where trigger a' = Var $ \a'' -> let e = if a' == a''
then NoEvent
else Event a''
in return (e, trigger a'')
onWhen :: Applicative m => (a -> Bool) -> Var m a (Event a)
onWhen f = var $ \a -> if f a then Event a else NoEvent
toEvent :: (Applicative m, Monad m) => Var m a b -> Var m a (Event b)
toEvent = (~> var Event)
collectWith :: (Monoid b, Applicative m, Monad m)
=> (a -> b -> b) -> Var m (Event a) b
collectWith f = Var $ \a -> collect' mempty a
where collect' b e = let b' = case e of
NoEvent -> b
Event a' -> f a' b
in return (b', Var $ \a' -> collect' b' a')
collect :: (Applicative m, Monad m) => Var m (Event a) [a]
collect = collectWith (:)
startingWith, startWith :: (Applicative m, Monad m) => a -> Var m (Event a) a
startingWith = startWith
startWith a = Var $ \e ->
return $ case e of
NoEvent -> (a, startWith a)
Event a' -> (a', startWith a')
holdWith :: (Applicative m, Monad m) => b -> Var m a (Event b) -> Var m a b
holdWith = flip hold
hold :: (Applicative m, Monad m) => Var m a (Event b) -> b -> Var m a b
hold w initial = Var $ \x -> do
(mb, w') <- runVar w x
return $ case mb of
NoEvent -> (initial, hold w' initial)
Event e -> (e, hold w' e)
between :: (Applicative m, Monad m)
=> Var m a (Event b) -> Var m a (Event c) -> Var m a (Event ())
between vb vc = (never `before` vb) `andThenE` (toEvent vu `before` vc) `andThen` between vb vc
where vu = pure ()
after :: (Applicative m, Monad m)
=> Var m a b -> Var m a (Event c) -> Var m a (Event b)
after vb ve = Var $ \a -> do
(_, vb') <- runVar vb a
(e, ve') <- runVar ve a
case e of
Event _ -> return (NoEvent, toEvent vb')
NoEvent -> return (NoEvent, vb' `after` ve')
beforeWith :: (Applicative m, Monad m)
=> Var m a b
-> (Var m a (Event b), b -> Var m a (Event b))
-> Var m a (Event b)
beforeWith vb (ve, f) = Var $ \a -> do
(b, vb') <- runVar vb a
(e, ve') <- runVar ve a
case e of
Event b' -> runVar (f b') a
NoEvent -> return (Event b, beforeWith vb' (ve', f))
beforeOne :: (Applicative m, Monad m) => Var m a b -> Var m a (Event b) -> Var m a (Event b)
beforeOne vb ve = Var $ \a -> do
(b, vb') <- runVar vb a
(e, ve') <- runVar ve a
case e of
Event b' -> return (Event b', never)
NoEvent -> return (Event b, vb' `beforeOne` ve')
before :: (Applicative m, Monad m) => Var m a b -> Var m a (Event c) -> Var m a (Event b)
before = until
until :: (Applicative m, Monad m) => Var m a b -> Var m a (Event c) -> Var m a (Event b)
until vb ve = Var $ \a -> do
(b, vb') <- runVar vb a
(e, ve') <- runVar ve a
case e of
Event _ -> return (NoEvent, never)
NoEvent -> return (Event b, vb' `until` ve')
once :: (Applicative m, Monad m) => b -> Var m a (Event b)
once b = Var $ \_ -> return (Event b, never)
takeE :: (Applicative m, Monad m) => Int -> Var m a (Event b) -> Var m a (Event b)
takeE n ve = Var $ \a -> do
(eb, ve') <- runVar ve a
case eb of
NoEvent -> return (NoEvent, takeE n ve')
Event b -> return (Event b, takeE (n1) ve')
filterE :: (Applicative m, Monad m) => (b -> Bool) -> Var m a (Event b) -> Var m a (Event b)
filterE p v = v ~> var check
where check (Event b) = if p b then Event b else NoEvent
check _ = NoEvent
never :: (Applicative m, Monad m) => Var m b (Event c)
never = pure NoEvent
always :: (Applicative m, Monad m) => b -> Var m a (Event b)
always = pure . Event
andThen :: (Applicative m, Monad m) => Var m a (Event b) -> Var m a b -> Var m a b
andThen w1 w2 = w1 `andThenWith` const w2
andThenE :: (Applicative m, Monad m)
=> Var m a (Event b) -> Var m a (Event b) -> Var m a (Event b)
andThenE y1 y2 = Var $ \a -> do
(e, y1') <- runVar y1 a
case e of
NoEvent -> runVar y2 a
Event b -> return $ (Event b, y1' `andThenE` y2)
andThenWith :: (Applicative m, Monad m)
=> Var m a (Event b) -> (Maybe b -> Var m a b) -> Var m a b
andThenWith = go Nothing
where go mb w1 f = Var $ \a -> do
(e, w1') <- runVar w1 a
case e of
NoEvent -> runVar (f mb) a
Event b -> return $ (b, go (Just b) w1' f)
switchByMode :: (Applicative m, Monad m, Eq b)
=> Var m a b -> (b -> Var m a c) -> Var m a c
switchByMode switch f = Var $ \a -> do
(b, _) <- runVar switch a
(_, v) <- runVar (f b) a
runVar (switchOnUnique v $ switch ~> onUnique) a
where switchOnUnique v sv = Var $ \a -> do
(eb, sv') <- runVar sv a
(c', v') <- runVar (vOf eb) a
return $ (c', switchOnUnique v' sv')
where vOf eb = case eb of
NoEvent -> v
Event b -> f b
onlyWhen :: (Applicative m, Monad m)
=> Var m a b
-> (a -> Bool)
-> Var m a (Event b)
onlyWhen v f = v `onlyWhenE` hot
where hot = var id ~> onWhen f
onlyWhenE :: (Applicative m, Monad m)
=> Var m a b
-> Var m a (Event c)
-> Var m a (Event b)
onlyWhenE v hot = Var $ \a -> do
(e, hot') <- runVar hot a
if isEvent e
then do (b, v') <- runVar v a
return (Event b, onlyWhenE v' hot')
else return (NoEvent, onlyWhenE v hot')
combineWith :: (Applicative m, Monad m)
=> (b -> c -> d) -> Var m a (Event b) -> Var m a (Event c)
-> Var m a (Event d)
combineWith f vb vc = (uncurry f <$>) <$> (combine vb vc)
combine :: (Applicative m, Monad m)
=> Var m a (Event b) -> Var m a (Event c) -> Var m a (Event (b,c))
combine vb vc = (\eb ec -> (,) <$> eb <*> ec) <$> vb <*> vc
instance Show a => Show (Event a) where
show (Event a) = "Event " ++ show a
show NoEvent = "NoEvent"
instance (Floating a) => Floating (Event a) where
pi = pure pi
exp = fmap exp
log = fmap log
sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh
cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh
atan = fmap atan; atanh = fmap atanh
instance (Fractional a) => Fractional (Event a) where
(/) = liftA2 (/)
fromRational = pure . fromRational
instance Num a => Num (Event a) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance MonadPlus Event
instance Monad Event where
return = Event
(Event a) >>= f = f a
_ >>= _ = NoEvent
instance Alternative Event where
empty = NoEvent
(<|>) (Event e) _ = Event e
(<|>) NoEvent e = e
instance Applicative Event where
pure = Event
(<*>) (Event f) (Event a) = Event $ f a
(<*>) _ _ = NoEvent
instance Functor Event where
fmap f (Event a) = Event $ f a
fmap _ NoEvent = NoEvent
data Event a = Event a | NoEvent deriving (Eq)