module Control.Varying.Event (
Event(..),
toMaybe,
isEvent,
orE,
use,
onTrue,
onJust,
onUnique,
onWhen,
foldStream,
startingWith, startWith,
filterE,
takeE,
dropE,
once,
always,
never,
switchByMode,
onlyWhen,
onlyWhenE,
) 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
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')
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
foldStream :: Monad m => (a -> t -> a) -> a -> Var m (Event t) a
foldStream f acc = Var $ \e ->
case e of
Event a -> let acc' = f acc a
in return (acc', foldStream f acc')
NoEvent -> return (acc, foldStream f acc)
startingWith, startWith :: (Applicative m, Monad m) => a -> Var m (Event a) a
startingWith = startWith
startWith = foldStream (\_ a -> a)
takeE :: (Applicative m, Monad m)
=> Int -> Var m a (Event b) -> Var m a (Event b)
takeE 0 _ = never
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 (n-1) ve')
dropE :: (Applicative m, Monad m)
=> Int -> Var m a (Event b) -> Var m a (Event b)
dropE 0 ve = ve
dropE n ve = Var $ \a -> do
(eb, ve') <- runVar ve a
case eb of
NoEvent -> return (NoEvent, dropE n ve')
Event _ -> return (NoEvent, dropE (n-1) 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
once :: (Applicative m, Monad m) => b -> Var m a (Event b)
once b = Var $ \_ -> return (Event b, never)
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
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')
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 where
mzero = mempty
mplus = (<|>)
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 Monoid (Event a) where
mempty = NoEvent
mappend a NoEvent = a
mappend _ b = b
instance Functor Event where
fmap f (Event a) = Event $ f a
fmap _ NoEvent = NoEvent
data Event a = Event a | NoEvent deriving (Eq)