-- {-# LANGUAGE TypeOperators, ScopedTypeVariables, PatternSignatures -- , FlexibleInstances -- #-} -- For ghc-6.6 compatibility {-# OPTIONS_GHC -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Data.Reactive -- Copyright : (c) Conal Elliott 2007 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Functional /events/ and /reactive values/. An 'Event' is stream of -- future values in time order. A 'Reactive' value is a discretly -- time-varying value. These two types are closely linked: a reactive -- value is defined by an initial value and an event that yields future -- values; while an event is simply a future reactive value. -- -- Many of the operations on events and reactive values are packaged as -- instances of the standard type classes 'Monoid', 'Functor', -- 'Applicative', and 'Monad'. -- -- Although the basic 'Reactive' type describes /discretely/-changing -- values, /continuously/-changing values are modeled simply as reactive -- functions. For convenience, this module defines 'ReactiveB' as a type -- composition of 'Reactive' and a constant-optimized representation of -- functions of time. -- -- The exact packaging of discrete vs continuous will probably change with -- more experience. ---------------------------------------------------------------------- module Data.Reactive ( -- * Events and reactive values Event(..), Reactive(..), Source, inEvent, inEvent2 , stepper, switcher, mkEvent, mkEventTrace, mkEventShow , runE, forkE, subscribe, forkR -- * Event extras , accumE, scanlE, monoidE , withPrevE, countE, countE_, diffE , snapshot, snapshot_, whenE, once, traceE, eventX -- * Reactive extras , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR -- * Reactive behaviors , Time, ReactiveB -- * To be moved elsewhere , replace, forget , Action, Sink , joinMaybes, filterMP ) where import Data.Monoid import Control.Arrow (first,second) import Control.Applicative import Control.Monad import Debug.Trace (trace) import Data.IORef import Control.Concurrent (forkIO,ThreadId) -- TypeCompose import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..)) import Data.Pair import Data.Future import Data.Fun {-------------------------------------------------------------------- Events and reactive values --------------------------------------------------------------------} -- | Event, i.e., a stream of future values. Instances: -- -- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend` -- e'@ is the event that combines occurrences from @e@ and @e'@. (Fran's -- @neverE@ and @(.|.)@.) -- -- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs, -- and whose occurrence values come from applying @f@ to the values from -- @e@. (Fran's @(==>)@.) -- -- * 'Applicative': @pure a@ is an event with a single occurrence, -- available from the beginning of time. @ef \<*\> ex@ is an event whose -- occurrences are made from the /product/ of the occurrences of @ef@ and -- @ex@. For every occurrence @f@ at time @tf@ of @ef@ and occurrence @x@ -- at time @tx@ of @ex@, @ef \<*\> ex@ has an occurrence @f x@ at time @max -- tf tx@. -- -- * 'Monad': @return a@ is the same as @pure a@ (as always). In @e >>= -- f@, each occurrence of @e@ leads, through @f@, to a new event. -- Similarly for @join ee@, which is somehow simpler for me to think -- about. The occurrences of @e >>= f@ (or @join ee@) correspond to the -- union of the occurrences of all such events. For example, suppose -- we're playing Asteroids and tracking collisions. Each collision can -- break an asteroid into more of them, each of which has to be tracked -- for more collisions. Another example: A chat room has an /enter/ -- event, whose occurrences contain new events like /speak/. -- newtype Event a = Event { eFuture :: Future (Reactive a) } -- | Reactive value: a discretely changing value. Reactive values can be -- understood in terms of (a) a simple denotational semantics of reactive -- values as functions of time, and (b) the corresponding instances for -- functions. The semantics is given by the function @(%$) :: Reactive a -- -> (Time -> a)@. A reactive value also has a current value and an -- event (stream of future values). -- -- Instances for 'Reactive' -- -- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then -- @Reactive o@ is a monoid, with @mempty = pure mempty@, and @mappend = -- liftA2 mappend@. In other words, @mempty %$ t == mempty@, and @(r -- `mappend` s) %$ t == (r %$ t) `mappend` (s %$ t).@ -- -- * 'Functor': @fmap f r %$ t == f (r %$ t)@. -- -- * 'Applicative': @pure a %$ t == a@, and @(s \<*\> r) %$ t == -- (s %$ t) (r %$ t)@. -- -- * 'Monad': @return a %$ t == a@, and @join rr %$ t == (rr %$ t) -- %$ t@. As always, @(r >>= f) == join (fmap f r)@. -- data Reactive a = Stepper { rInit :: a -- ^ initial value , rEvent :: Event a -- ^ waiting for event } -- data Reactive a = a `Stepper` Event a -- | Reactive value from an initial value and a new-value event. stepper :: a -> Event a -> Reactive a stepper = Stepper -- | Compatibility synonym (for ease of transition from DataDriven) type Source = Reactive -- | Apply a unary function inside an 'Event' representation. inEvent :: (Future (Reactive a) -> Future (Reactive b)) -> (Event a -> Event b) inEvent f = Event . f . eFuture -- | Apply a unary function inside an 'Event' representation. inEvent2 :: (Future (Reactive a) -> Future (Reactive b) -> Future (Reactive c)) -> (Event a -> Event b -> Event c) inEvent2 f = inEvent . f . eFuture -- Why the newtype for Event? Because the 'Monoid' instance of 'Future' -- does not do what I want for 'Event'. It will pick just the -- earlier-occurring event, while I want an interleaving of occurrences -- from each. instance Monoid (Event a) where mempty = Event mempty mappend = inEvent2 merge -- Standard instance for Applicative of Monoid instance Monoid a => Monoid (Reactive a) where mempty = pure mempty mappend = liftA2 mappend -- | Merge two 'Future' streams into one. merge :: Future (Reactive a) -> Future (Reactive a) -> Future (Reactive a) Never `merge` fut = fut fut `merge` Never = fut u `merge` v = (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v) where onFut f (a `Stepper` Event t') = a `stepper` Event (f t') instance Functor Event where fmap f = inEvent $ (fmap.fmap) f -- I could probably define an Applicative instance like []'s for Event, -- i.e., apply all functions to all arguments. I don't think I want that -- semantics. instance Functor Reactive where fmap f (a `Stepper` e) = f a `stepper` fmap f e instance Applicative Event where { pure = return; (<*>) = ap } instance Applicative Reactive where pure a = a `stepper` mempty rf@(f `Stepper` Event vf) <*> rx@(x `Stepper` Event vx) = f x `stepper` Event (((<*> rx) <$> vf) `mappend` ((rf <*>) <$> vx)) -- A wonderful thing about the <*> definition for Reactive is that it -- automatically caches the previous value of the function or argument -- when the argument or function changes. -- TODO: The definitions of merge and <*> have some similarities. Can I -- factor out a common pattern? instance Monad Event where return a = Event (pure (pure a)) e >>= f = joinE (fmap f e) joinE :: forall a. Event (Event a) -> Event a joinE = inEvent q where q :: Future (Reactive (Event a)) -> Future (Reactive a) q = (>>= eFuture . h) h :: Reactive (Event a) -> Event a h (ea `Stepper` eea) = ea `mappend` joinE eea instance MonadPlus Event where { mzero = mempty; mplus = mappend } instance Monad Reactive where return = pure r >>= h = joinR (fmap h r) -- | Switch between reactive values. switcher :: Reactive a -> Event (Reactive a) -> Reactive a r `switcher` e = joinR (r `stepper` e) -- Reactive 'join' joinR :: Reactive (Reactive a) -> Reactive a joinR ((a `Stepper` Event fut) `Stepper` e'@(Event fut')) = a `stepper` Event fut'' where -- If fut arrives first, switch and continue waiting for e'. -- If fut' arrives first, abandon fut and keep switching with new -- reactive values from fut'. fut'' = fmap (`switcher` e') fut `mappend` fmap join fut' -- | Make an event and a sink for feeding the event. Each value sent to -- the sink becomes an occurrence of the event. mkEvent :: IO (Event a, Sink a) mkEvent = do (fut,snk) <- newFuture -- remember how to save the next occurrence. r <- newIORef snk return (Event fut, writeTo r) where -- Fill in an occurrence while preparing for the next one writeTo r a = do snk <- readIORef r (fut',snk') <- newFuture writeIORef r snk' snk (a `stepper` Event fut') -- | Tracing variant of 'mkEvent' mkEventTrace :: (a -> String) -> IO (Event a, Sink a) mkEventTrace shw = second tr <$> mkEvent where tr snk = (putStrLn.shw) `mappend` snk -- | Show specialization of 'mkEventTrace' mkEventShow :: Show a => String -> IO (Event a, Sink a) mkEventShow str = mkEventTrace ((str ++).(' ':).show) -- | Run an event in a new thread. forkE :: Event (IO b) -> IO ThreadId forkE = forkIO . runE -- | Subscribe a listener to an event. Wrapper around 'forkE' and 'fmap'. subscribe :: Event a -> Sink a -> IO ThreadId subscribe e snk = forkE (snk <$> e) -- | Run an event in the current thread. runE :: Event (IO b) -> IO a runE (Event fut) = do act `Stepper` e' <- force fut act runE e' -- | Run a reactive value in a new thread. The initial action happens in -- the current thread. forkR :: Reactive (IO b) -> IO ThreadId forkR (act `Stepper` e) = act >> forkE e {-------------------------------------------------------------------- Event extras --------------------------------------------------------------------} -- | Accumulating event, starting from an initial value and a -- update-function event. See also 'accumR'. accumE :: a -> Event (a -> a) -> Event a accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e' -- | Like 'scanl' for events. See also 'scanE'. scanlE :: (a -> b -> a) -> a -> Event b -> Event a scanlE f a e = a `accumE` (flip f <$> e) -- | Accumulate values from a monoid-valued event. Specialization of -- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidR'. monoidE :: Monoid o => Event o -> Event o monoidE = scanlE mappend mempty -- | Pair each event value with the previous one, given an initial value. withPrevE :: Event a -> Event (a,a) withPrevE e = (joinMaybes . fmap combineMaybes) $ (Nothing,Nothing) `accumE` fmap (shift.Just) e where -- Shift newer value into (old,new) pair if present. shift :: u -> Unop (u,u) shift new (_,old) = (old,new) combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v) combineMaybes = uncurry (liftA2 (,)) -- | Count occurrences of an event, remembering the occurrence values. -- See also 'countE_'. countE :: Num n => Event b -> Event (b,n) countE = scanlE h (b0,0) where b0 = error "withCountE: no initial value" h (_,n) b = (b,n+1) -- | Count occurrences of an event, forgetting the occurrence values. See -- also 'countE'. See also 'countR'. countE_ :: Num n => Event b -> Event n countE_ e = snd <$> countE e -- | Difference of successive event occurrences. diffE :: Num n => Event n -> Event n diffE e = uncurry (-) <$> withPrevE e -- | Snapshot a reactive value whenever an event occurs. snapshot :: Event a -> Reactive b -> Event (a,b) e `snapshot` r = joinMaybes $ e `snap` r -- This variant of 'snapshot' yields 'Just's when @e@ happens and -- 'Nothing's when @r@ changes. snap :: forall a b. Event a -> Reactive b -> Event (Maybe (a,b)) e@(Event ve) `snap` r@(b `Stepper` Event vr) = Event ((g <$> ve) `mappend` (h <$> vr)) where -- When e occurs, produce a pair, and start snapshotting the old -- reactive value with the new event. g :: Reactive a -> Reactive (Maybe (a,b)) g (a `Stepper` e') = Just (a,b) `stepper` (e' `snap` r) -- When r changes, produce no pair, and start snapshotting the new -- reactive value with the old event. h :: Reactive b -> Reactive (Maybe (a,b)) h r' = Nothing `stepper` (e `snap` r') -- Introducing Nothing above allows the mappend to commit to the RHS. -- | Like 'snapshot' but discarding event data (often @a@ is @()@). snapshot_ :: Event a -> Reactive b -> Event b e `snapshot_` src = snd <$> (e `snapshot` src) -- | Filter an event according to whether a boolean source is true. whenE :: Event a -> Reactive Bool -> Event a whenE e = joinMaybes . fmap h . snapshot e where h (a,True) = Just a h (_,False) = Nothing -- | Just the first occurrence of an event. once :: Event a -> Event a once = inEvent $ fmap $ pure . rInit -- | Tracing of events. traceE :: (a -> String) -> Unop (Event a) traceE shw = fmap (\ a -> trace (shw a) a) -- | Make an extensible event. The returned sink is a way to add new -- events to mix. You can often use '(>>=)' or 'join' instead. Warning: -- this function might be removed at some point. eventX :: IO (Event a, Sink (Event a)) eventX = first join <$> mkEvent {-------------------------------------------------------------------- Reactive extras --------------------------------------------------------------------} mkReactive :: a -> IO (Reactive a, Sink a) mkReactive a0 = first (a0 `stepper`) <$> mkEvent -- | Reactive value from an initial value and an updater event. See also 'accumE'. accumR :: a -> Event (a -> a) -> Reactive a a `accumR` e = a `stepper` (a `accumE` e) -- | Like 'scanl' for reactive values. See also 'scanE'. scanlR :: (a -> b -> a) -> a -> Event b -> Reactive a scanlR f a e = a `stepper` scanlE f a e -- | Accumulate values from a monoid-valued event. Specialization of -- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'. monoidR :: Monoid a => Event a -> Reactive a monoidR = scanlR mappend mempty -- | Start out blank ('Nothing'), latching onto each new @a@, and blanking -- on each @b@. If you just want to latch and not blank, then use -- 'mempty' for @lose@. maybeR :: Event a -> Event b -> Reactive (Maybe a) maybeR get lose = Nothing `stepper` (fmap Just get `mappend` replace Nothing lose) -- | Flip-flopping source. Turns true when @ea@ occurs and false when -- @eb@ occurs. flipFlop :: Event a -> Event b -> Reactive Bool flipFlop ea eb = False `stepper` (replace True ea `mappend` replace False eb) -- TODO: generalize 'maybeR' & 'flipFlop'. Perhaps using 'Monoid'. -- Note that Nothing and (Any False) are mempty. -- | Count occurrences of an event. See also 'countE'. countR :: Num n => Event a -> Reactive n countR e = 0 `stepper` countE_ e -- | Tracing of reactive values traceR :: (a -> String) -> Unop (Reactive a) traceR shw (a `Stepper` e) = a `Stepper` traceE shw e {-------------------------------------------------------------------- Other instances --------------------------------------------------------------------} -- Standard instances instance Pair Reactive where pair = liftA2 (,) instance (Monoid_f f) => Monoid_f (Reactive :. f) where { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) } instance Pair f => Pair (Reactive :. f) where pair = apPair instance Unpair Reactive where {pfst = fmap fst; psnd = fmap snd} -- Standard instances instance Monoid_f Event where { mempty_f = mempty ; mappend_f = mappend } instance Monoid ((Event :. f) a) where { mempty = O mempty; mappend = inO2 mappend } instance Monoid_f (Event :. f) where { mempty_f = mempty ; mappend_f = mappend } instance Copair f => Pair (Event :. f) where pair = copair -- Standard instance for functors instance Unpair Event where {pfst = fmap fst; psnd = fmap snd} {-------------------------------------------------------------------- Reactive behaviors over continuous time --------------------------------------------------------------------} -- | Time for continuous behaviors type Time = Double -- | Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in -- a type composition to get 'Functor' and 'Applicative' for free. type ReactiveB = Reactive :. Fun Time {-------------------------------------------------------------------- To be moved elsewhere --------------------------------------------------------------------} -- | Replace a functor value with a given one. replace :: Functor f => b -> f a -> f b replace b = fmap (const b) -- | Forget a functor value, replace with @()@ forget :: Functor f => f a -> f () forget = replace () -- | Convenient alias for dropping parentheses. type Action = IO () -- | Value sink type Sink a = a -> Action -- | Pass through @Just@ occurrences. joinMaybes :: MonadPlus m => m (Maybe a) -> m a joinMaybes = (>>= maybe mzero return) -- | Pass through values satisfying @p@. filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a filterMP p m = joinMaybes (liftM f m) where f a | p a = Just a | otherwise = Nothing -- Alternatively: -- filterMP p m = m >>= guarded p -- where -- guarded p x = guard (p x) >> return x