module Control.Varying.Event (
Event(..),
toMaybe,
isEvent,
orE,
use,
onTrue,
onJust,
onUnique,
onWhen,
foldStream,
startingWith, startWith,
eitherE,
anyE,
filterE,
takeE,
dropE,
once,
always,
never,
andThenWith,
switchByMode,
onlyWhen,
onlyWhenE,
) where
import Prelude hiding (until)
import Control.Varying.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Foldable (foldl')
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) => VarT m a b -> VarT m a (Event b) -> VarT m a b
orE y ye = VarT $ \a -> do
(b, y') <- runVarT y a
(e, ye') <- runVarT 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) => VarT m Bool (Event ())
onTrue = var $ \b -> if b then Event () else NoEvent
onJust :: (Applicative m, Monad m) => VarT m (Maybe a) (Event a)
onJust = var $ \ma -> case ma of
Nothing -> NoEvent
Just a -> Event a
onUnique :: (Applicative m, Monad m, Eq a) => VarT m a (Event a)
onUnique = VarT $ \a -> return (Event a, trigger a)
where trigger a' = VarT $ \a'' -> let e = if a' == a''
then NoEvent
else Event a''
in return (e, trigger a'')
onWhen :: Applicative m => (a -> Bool) -> VarT m a (Event a)
onWhen f = var $ \a -> if f a then Event a else NoEvent
foldStream :: Monad m => (a -> t -> a) -> a -> VarT m (Event t) a
foldStream f acc = VarT $ \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 -> VarT m (Event a) a
startingWith = startWith
startWith = foldStream (\_ a -> a)
takeE :: (Applicative m, Monad m)
=> Int -> VarT m a (Event b) -> VarT m a (Event b)
takeE 0 _ = never
takeE n ve = VarT $ \a -> do
(eb, ve') <- runVarT ve a
case eb of
NoEvent -> return (NoEvent, takeE n ve')
Event b -> return (Event b, takeE (n1) ve')
dropE :: (Applicative m, Monad m)
=> Int -> VarT m a (Event b) -> VarT m a (Event b)
dropE 0 ve = ve
dropE n ve = VarT $ \a -> do
(eb, ve') <- runVarT ve a
case eb of
NoEvent -> return (NoEvent, dropE n ve')
Event _ -> return (NoEvent, dropE (n1) ve')
filterE :: (Applicative m, Monad m)
=> (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b)
filterE p v = v >>> var check
where check (Event b) = if p b then Event b else NoEvent
check _ = NoEvent
eitherE :: (Applicative m, Monad m)
=> VarT m a (Event b) -> VarT m a (Event c)
-> VarT m a (Event (Either b c))
eitherE vb vc = f <$> vb <*> vc
where f (Event b) _ = Event $ Left b
f _ (Event c) = Event $ Right c
f _ _ = NoEvent
anyE :: (Applicative m, Monad m) => [VarT m a (Event b)] -> VarT m a (Event b)
anyE [] = never
anyE vs = VarT $ \a -> do
outs <- mapM (`runVarT` a) vs
let f (eb, vs1) (eb1, v) = (msum [eb, eb1], vs1 ++ [v])
return (anyE <$> foldl' f (NoEvent, []) outs)
once :: (Applicative m, Monad m) => b -> VarT m a (Event b)
once b = VarT $ \_ -> return (Event b, never)
never :: (Applicative m, Monad m) => VarT m b (Event c)
never = pure NoEvent
always :: (Applicative m, Monad m) => b -> VarT m a (Event b)
always = pure . Event
switchByMode :: (Applicative m, Monad m, Eq b)
=> VarT m a b -> (b -> VarT m a c) -> VarT m a c
switchByMode switch f = VarT $ \a -> do
(b, _) <- runVarT switch a
(_, v) <- runVarT (f b) a
runVarT (switchOnUnique v $ switch >>> onUnique) a
where switchOnUnique v sv = VarT $ \a -> do
(eb, sv') <- runVarT sv a
(c', v') <- runVarT (vOf eb) a
return (c', switchOnUnique v' sv')
where vOf eb = case eb of
NoEvent -> v
Event b -> f b
andThenWith :: (Applicative m, Monad m)
=> VarT m a (Event b) -> (Event b -> VarT m a (Event b)) -> VarT m a (Event b)
v `andThenWith` f = run v NoEvent
where run v1 eb = VarT $ \a -> do
(eb1, v2) <- runVarT v1 a
case eb1 of
NoEvent -> runVarT (f eb) a
_ -> return (eb1, run v2 eb1)
onlyWhen :: (Applicative m, Monad m)
=> VarT m a b
-> (a -> Bool)
-> VarT m a (Event b)
onlyWhen v f = v `onlyWhenE` hot
where hot = var id >>> onWhen f
onlyWhenE :: (Applicative m, Monad m)
=> VarT m a b
-> VarT m a (Event c)
-> VarT m a (Event b)
onlyWhenE v hot = VarT $ \a -> do
(e, hot') <- runVarT hot a
if isEvent e
then do (b, v') <- runVarT 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)