reactive-banana 0.1.0.2 → 0.2.0.0
raw patch · 9 files changed
+927/−577 lines, 9 filesdep +QuickCheckdep +monads-tfdep +transformers
Dependencies added: QuickCheck, monads-tf, transformers
Files
- reactive-banana.cabal +32/−13
- src/Reactive.hs +0/−15
- src/Reactive/Banana.hs +20/−0
- src/Reactive/Banana/Implementation.hs +186/−0
- src/Reactive/Banana/Model.hs +261/−0
- src/Reactive/Banana/PushIO.hs +364/−0
- src/Reactive/Banana/Tests.hs +64/−0
- src/Reactive/Classes.hs +0/−29
- src/Reactive/Core.hs +0/−520
reactive-banana.cabal view
@@ -1,23 +1,32 @@ Name: reactive-banana-Version: 0.1.0.2-Synopsis: Small but flexible- functional reactive programming (FRP) library.+Version: 0.2.0.0+Synopsis: Small but solid library for+ functional reactive programming (FRP). Description: - A small but flexible library for functional reactive programming (FRP).+ A small but solid library for functional reactive programming (FRP). .- The main selling point of this library is that it- can be hooked into /any/ existing event-based framework.- In a sense, @reactive-banana@ is a fresh way to think- about callback functions.+ The current focus of this library is to implement+ a subset of the semantic model for functional reactive programming+ pioneered by Conal Elliott. .- In other words, you can freely mix FRP and imperative code.- Bored of writing imperative GUIs? Write some parts with FRP!+ Moreover, this library can hooked into /any/+ existing event-based framework.+ It is especially useful in conjunction with existing+ GUI frameworks like @wxHaskell@ or @gtk2hs@.+ .+ This also means that your code can be a mix of FRP and imperative parts.+ Bored of programming imperative GUIs? Write some parts with FRP! Don't know how to express something with FRP? Switch back to imperative style! . In the spectrum of possible FRP implementations, this one features simple semantics but modest expressivity. Predicting space & time usage should be easy.+ .+ Stability forecast:+ Known inefficiencies that will be addressed.+ No semantic bugs expected.+ Significant API changes are likely in future versions. Homepage: https://github.com/HeinrichApfelmus/Haskell-BlackBoard License: BSD3 License-file: LICENSE@@ -34,6 +43,16 @@ Library hs-source-dirs: src- extensions: MultiParamTypeClasses, FlexibleInstances- build-depends: base >= 4.2 && < 4.4- exposed-modules: Reactive, Reactive.Classes, Reactive.Core+ extensions: TypeFamilies, FlexibleContexts,+ FlexibleInstances, EmptyDataDecls,+ GADTs, BangPatterns, TupleSections,+ Rank2Types, NoMonomorphismRestriction+ build-depends:+ base >= 4.2 && < 4.4,+ monads-tf == 0.1.*, transformers == 0.2.*,+ QuickCheck == 2.4.*+ exposed-modules: Reactive.Banana, Reactive.Banana.Model,+ Reactive.Banana.Implementation,+ Reactive.Banana.Tests+ other-modules: Reactive.Banana.PushIO+
− src/Reactive.hs
@@ -1,15 +0,0 @@-{------------------------------------------------------------------------------ Reactive Banana-- A tiny library for functional reactive programming.-------------------------------------------------------------------------------}--module Reactive (- module Control.Applicative,- module Reactive.Core,- module Reactive.Classes,- ) where--import Control.Applicative-import Reactive.Core-import Reactive.Classes
+ src/Reactive/Banana.hs view
@@ -0,0 +1,20 @@+{-----------------------------------------------------------------------------+ Reactive Banana++ A small library for functional reactive programming.+------------------------------------------------------------------------------}++module Reactive.Banana (+ module Reactive.Banana.Model,+ module Reactive.Banana.Implementation,++ Event, Behavior+ ) where++import Reactive.Banana.Model hiding (run, Event, Behavior)+import qualified Reactive.Banana.Model as Model+import Reactive.Banana.Implementation+import qualified Reactive.Banana.Implementation as Implementation++type Event = Model.Event PushIO+type Behavior = Model.Behavior PushIO
+ src/Reactive/Banana/Implementation.hs view
@@ -0,0 +1,186 @@+{-----------------------------------------------------------------------------+ Reactive Banana+ + Linking any implementation to an event-based framework+------------------------------------------------------------------------------}+module Reactive.Banana.Implementation (+ -- * Synopsis+ -- | Run event networks and hook them up to existing event-based frameworks.+ + -- * Implementation+ PushIO, run,++ -- * Using existing event-based frameworks+ -- $Prepare+ Prepare, prepareEvents, reactimate, AddHandler, fromAddHandler, liftIO,+ + module Data.Dynamic,+ ) where++import Reactive.Banana.PushIO as Implementation+-- import Reactive.Banana.Model hiding (Event, Behavior, run)+import qualified Reactive.Banana.Model as Model+import Data.Dynamic++import Data.List (nub)+import Control.Applicative+import Control.Monad.RWS+import Data.IORef++{-----------------------------------------------------------------------------+ PushIO specific functions+------------------------------------------------------------------------------}+type Flavor = PushIO++input :: Typeable a => Channel -> Model.Event PushIO a+input = event . Input++compileHandlers :: Model.Event Flavor (IO ()) -> IO [(Channel, Universe -> IO ())]+compileHandlers network = do+ -- compile network+ let network' = Implementation.unEvent network+ (paths,cache) <- Implementation.compile (invalidRef, Reactimate network')+ -- reduce to one path per channel+ let paths1 = groupChannelsBy (\p q x -> p x >> q x) paths++ -- prepare threading the cache as state+ rcache <- newIORef emptyCache+ writeIORef rcache cache+ let run m = do+ cache <- readIORef rcache+ (_,cache') <- runRun m cache+ writeIORef rcache cache'+ paths2 = map (\(i,p) -> (i, run . p)) $ paths1+ + return paths2+++-- FIXME: make this faster+groupChannelsBy :: (a -> a -> a) -> [(Channel, a)] -> [(Channel, a)]+groupChannelsBy f xs = [(i, foldr1 f [x | (j,x) <- xs, i == j]) | i <- channels]+ where channels = nub . map fst $ xs++{-----------------------------------------------------------------------------+ Setting up an event network+------------------------------------------------------------------------------}+{-$Prepare++ After having read all about 'Event's and 'Behavior's,+ you want to hook things up to an existing event-based framework,+ like @wxHaskell@ or @Gtk2Hs@.+ How do you do that?++ To do that, you have to use the 'Prepare' monad.+ The typical setup looks like this:+ +> main = do+> ... -- other initialization+>+> -- initialize event network+> prepareEvents $ do+> -- obtain Event from functions that register event handlers+> emouse <- fromAddHandler (registerMouseEvent window)+> ekeyboard <- fromAddHandler (registerKeyEvent window)+> +> -- build event network+> let+> behavior1 = accumB ...+> ...+> event15 = union event13 event14+> +> -- animate relevant event occurences+> reactimate $ fmap print event15+> reactimate $ fmap drawCircle eventCircle+>+> ... -- start the GUI framework here+ + In short, you use 'fromAddHandler' to obtain /input events/;+ the library will register corresponding event handlers+ with your event-based framework.+ + To animate /output events/, you use the 'reactimate' function.+ + The whole setup has to be wrapped into a call to 'prepareEvents'.+ + The 'Prepare' monad is an instance of 'MonadIO',+ so 'IO' is allowed inside. However, you can't pass anything+ of type @Event@ or @Behavior@ outside the 'prepareEvents' call;+ this is intentional.+ (You can probably circumvent this with mutable variables,+ but there is a 99,8% chance that earth will be suspended+ by time-traveling zygohistomorphisms+ if you do that; you have been warned.)++-}++type AddHandler' = (Channel, (Universe -> IO ()) -> IO ())+type Preparations = ([Model.Event Flavor (IO ())], [AddHandler'])+newtype Prepare a = Prepare { unPrepare :: RWST () Preparations Channel IO a }++instance Monad (Prepare) where+ return = Prepare . return+ m >>= k = Prepare $ unPrepare m >>= unPrepare . k+instance MonadIO Prepare where+ liftIO = Prepare . liftIO++-- | Animate an output event.+-- Executes the 'IO' action whenever the event occurs.+reactimate :: Model.Event PushIO (IO ()) -> Prepare ()+reactimate e = Prepare $ tell ([e], [])++-- | Wrap around the 'Prepare' monad to set up an event network.+prepareEvents :: Prepare () -> IO ()+prepareEvents (Prepare m) = do+ (_,_,(outputs,inputs)) <- runRWST m () 0+ let+ -- union of all reactimates+ network = mconcat outputs :: Model.Event PushIO (IO ())+ -- compile network+ paths <- compileHandlers network+ -- register event handlers+ sequence_ . map snd . applyChannels inputs $ paths++-- FIXME: make this faster+applyChannels :: [(Channel, a -> b)] -> [(Channel, a)] -> [(Channel, b)]+applyChannels fs xs =+ [(i, f x) | (i,f) <- fs, (j,x) <- xs, i == j]++-- | A value of type @AddHandler a@ is just an IO function that registers+-- callback functions, also known as event handlers. +type AddHandler a = (a -> IO ()) -> IO ()++-- | Obtain an 'Event' from an 'AddHandler'.+-- This will register a callback function such that+-- an event will occur whenever the callback function is called.+fromAddHandler :: Typeable a => AddHandler a -> Prepare (Model.Event PushIO a)+fromAddHandler addHandler = Prepare $ do+ channel <- newChannel+ let addHandler' k = addHandler $ k . toUniverse channel+ tell ([], [(channel, addHandler')])+ return $ input channel+ where+ newChannel = do c <- get; put $! c+1; return c++{-----------------------------------------------------------------------------+ Run function for testing+------------------------------------------------------------------------------}+-- | Running an event network for the purpose of easy testing.+run :: Typeable a+ => (Model.Event PushIO a -> Model.Event PushIO b) -> [a] -> IO [[b]]+run f xs = do+ oref <- newIORef []++ href <- newIORef []+ let addHandler k = modifyIORef href (++[k])++ prepareEvents $ do+ e <- fromAddHandler addHandler+ reactimate $ fmap (\b -> modifyIORef oref (++[b])) (f e)++ handler <- (\ks x -> mapM ($ x) ks) <$> readIORef href++ forM xs $ \x -> do+ handler x+ bs <- readIORef oref+ writeIORef oref []+ return bs
+ src/Reactive/Banana/Model.hs view
@@ -0,0 +1,261 @@+{-----------------------------------------------------------------------------+ Reactive Banana+ + Class interface + Semantic model+------------------------------------------------------------------------------}+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, EmptyDataDecls #-}+module Reactive.Banana.Model (+ -- * Synopsis+ -- | Combinators for building event networks and their semantics.+ + -- * Combinators+ module Control.Applicative,+ FRP(..),+ + Event, Behavior,+ -- $classes+ whenE, mapAccum,+ + -- * Model implementation+ Model,+ Time, interpret, run,+ ) where++import Control.Applicative+import qualified Data.List+import Prelude hiding (filter)+import Data.Monoid++{-----------------------------------------------------------------------------+ Class interface+------------------------------------------------------------------------------}+data family Event f :: * -> *+data family Behavior f :: * -> *++{- | The 'FRP' class defines the primitive API for functional reactive programming.+Each instance 'f' defines two type constructors @Event f@ and @Behavior f@+and corresponding combinators.++@Event f a@ represents a stream of events as they occur in time.+Semantically, you can think of @Event f a@ as an infinite list of values+that are tagged with their corresponding time of occurence,++> type Event f a = [(Time,a)]++@Behavior f a@ represents a value that varies in time. Think of it as++> type Behavior f a = Time -> a++While these type synonyms are the way you should think about+'Behavior' and 'Event', they are a bit vague for formal manipulation.+To remedy this, the library provides a very simple model implementation,+called 'Model'.+This model is /authoritative/: every instance of the 'FRP' class /must/+give the same results as the model when observed with the 'interpret' function.+Note that this must also hold for recursive and partial definitions+(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).++Concerning time and space complexity, the model is not authoritative, however.+Implementations are free to be much more efficient.++Minimal complete definition of the 'FRP' class: One of 'filter' or 'filterApply'+and one of 'accumB' or 'stepper'.++-}++class (Functor (Event f),+ Functor (Behavior f), Applicative (Behavior f)) => FRP f where+ + -- | Event that never occurs.+ -- Think of it as @never = []@.+ never :: Event f a+ + -- | Merge two event streams of the same type.+ -- In case of simultaneous occurrences, the left argument comes first.+ -- Think of it as+ --+ -- > union ((timex,x):xs) ((timey,y):ys)+ -- > | timex <= timey = (timex,x) : union xs ((timey,y):ys)+ -- > | timex > timey = (timey,y) : union ((timex,x):xs) ys+ union :: Event f a -> Event f a -> Event f a+ + -- | Apply a time-varying function to a stream of events.+ -- Think of it as+ -- + -- > apply bf ex = [(time, bf time x) | (time, x) <- ex]+ apply :: Behavior f (a -> b) -> Event f a -> Event f b+++ -- | Allow all events that fulfill the predicate, discard the rest.+ -- Think of it as+ -- + -- > filter p es = [(time,a) | (time,a) <- es, p a]+ filter :: (a -> Bool) -> Event f a -> Event f a+ + -- | Allow all events that fulfill the time-varying predicate, discard the rest.+ -- It's a slight generalization of 'filter'.+ filterApply :: Behavior f (a -> Bool) -> Event f a -> Event f a+ + + -- Accumulation.+ -- Note: all accumulation functions are strict in the accumulated value!+ -- acc -> (x,acc) is the order used by unfoldr and State++ -- | Construct a time-varying function from an initial value and + -- a stream of new values. Think of it as+ --+ -- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time])+ -- + -- Note that the smaller-than-sign in the comparision @timex < time@ means + -- that the value of the behavior changes \"slightly after\"+ -- the event occurrences. This allows for recursive definitions.+ -- + -- Also note that in the case of simultaneous occurrences,+ -- only the last one is kept.+ stepper :: a -> Event f a -> Behavior f a++ -- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''.+ -- It starts with an initial value and combines it with incoming events.+ -- For example, think+ --+ -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))]+ -- > = behavior "x" [(time1,"yx"),(time2,"zyx")]+ -- + -- Note that the value of the behavior changes \"slightly after\"+ -- the events occur. This allows for recursive definitions.+ accumB :: a -> Event f (a -> a) -> Behavior f a+ + -- | The 'accumE' function accumulates a stream of events.+ -- Note that the output events are simultaneous with the input events,+ -- there is no \"delay\" like in the case of 'accumB'.+ accumE :: a -> Event f (a -> a) -> Event f a+ + + -- implementation filter+ filter p = filterApply (pure p)+ filterApply bp = fmap snd . filter fst . apply ((\p a-> (p a,a)) <$> bp) + + -- implementation accumulation+ accumB acc = stepper acc . accumE acc+ stepper acc = accumB acc . fmap const++{-$classes++/Further combinators that Haddock can't document properly./++> instance FRP f => Monoid (Event f a)++The combinators 'never' and 'union' turn 'Event' into a monoid.++> instance FPR f => Applicative (Behavior f)++'Behavior' is an applicative functor. In particular, we have the following functions.++> pure :: FRP f => a -> Behavior f a++The constant time-varying value. Think of it as @pure x = \\time -> x@.++> (<*>) :: FRP f => Behavior f (a -> b) -> Behavior f a -> Behavior f b++Combine behaviors in applicative style.+Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@.++-}++instance FRP f => Monoid (Event f a) where+ mempty = never+ mappend = union++{-----------------------------------------------------------------------------+ Derived Combinators+------------------------------------------------------------------------------}+-- | Variant of 'filterApply'.+whenE :: FRP f => Behavior f Bool -> Event f a -> Event f a+whenE bf = filterApply (const <$> bf)++-- | Efficient combination of 'accumE' and 'accumB'.+mapAccum :: FRP f => acc -> Event f (acc -> (x,acc)) -> (Event f x, Behavior f acc)+mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e))+ where e = accumE (undefined,acc) ((. snd) <$> ef)++{-----------------------------------------------------------------------------+ Semantic model+------------------------------------------------------------------------------}+-- | The type index 'Model' represents the model implementation.+-- You are encouraged to look at the source code!+-- (If there is no link to the source code at every type signature,+-- then you have to run @cabal@ with @--hyperlink-source@ flag.)+data Model++-- Stream of events. Simultaneous events are grouped into lists.+newtype instance Event Model a = E { unE :: [[a]] }+-- Stream of values that the behavior takes.+newtype instance Behavior Model a = B { unB :: [a] }+++instance Functor (Event Model) where+ fmap f = E . map (map f) . unE++instance Applicative (Behavior Model) where+ pure x = B $ repeat x+ bf <*> bx = B $ zipWith ($) (unB bf) (unB bx)++instance Functor (Behavior Model) where+ fmap = liftA++instance FRP Model where+ never = E $ repeat []+ union e1 e2 = E $ zipWith (++) (unE e1) (unE e2)+ + filterApply bp = E . zipWith (\p xs-> Data.List.filter p xs) (unB bp) . unE+ apply b = E . zipWith (\f xs -> map f xs) (unB b) . unE++ stepper x = B . scanl go x . unE+ where go x e = last (x:e)++ accumE acc = E . accumE' acc . unE+ where+ accumE' acc [] = []+ accumE' acc (e:es) = e' : accumE' acc' es+ where+ e' = tail $ scanl' (flip ($)) acc e+ acc' = last e'++-- strict version of scanl+scanl' :: (a -> b -> a) -> a -> [b] -> [a]+scanl' f x ys = x : case ys of+ [] -> []+ y:ys -> let z = f x y in z `seq` scanl' f z ys++-- | Slightly simpler interpreter that does not mention 'Time'.+-- Returns lists of event values that occur simultaneously.+run :: (Event Model a -> Event Model b) -> [a] -> [[b]]+run f = unE . f . E . map (:[])++type Time = Double+-- | Interpreter that corresponds to your mental model.+interpret :: (Event Model a -> Event Model b) -> [(Time,a)] -> [(Time,b)]+interpret f xs =+ concat . zipWith tag times . run f . map snd $ xs+ where+ times = map fst xs+ tag t xs = map (\x -> (t,x)) xs++{-----------------------------------------------------------------------------+ Example: Counter that can be decreased+------------------------------------------------------------------------------}+example :: FRP f => Event f () -> Event f Int+example edec = apply ((\c _ -> c) <$> bcounter) ecandecrease+ where+ bcounter = accumB 10 $ (subtract 1) <$ ecandecrease+ ecandecrease = whenE ((>0) <$> bcounter) edec++testModel = run example $ replicate 15 ()+-- > testModel+-- [[10],[9],[8],[7],[6],[5],[4],[3],[2],[1],[],[],[],[],[]]++example2 :: FRP f => Event f () -> Event f Int+example2 e = apply (const <$> b) e+ where+ b = accumB 0 ((+1) <$ e)+
+ src/Reactive/Banana/PushIO.hs view
@@ -0,0 +1,364 @@+{-----------------------------------------------------------------------------+ Reactive Banana+ + A push-driven implementation+------------------------------------------------------------------------------}+{-# LANGUAGE TypeFamilies, FlexibleInstances, EmptyDataDecls, GADTs,+ TupleSections, BangPatterns #-}+module Reactive.Banana.PushIO where++import Reactive.Banana.Model hiding (Event, Behavior, run)+import qualified Reactive.Banana.Model as Model++import Control.Applicative+import qualified Data.List+import Prelude hiding (filter)+import Data.Monoid++import Control.Monad.Trans.Identity+import Control.Monad.State+import Control.Monad.Writer++import Data.IORef+import System.IO.Unsafe+import Data.Dynamic++{-----------------------------------------------------------------------------+ Observable sharing+ + References can be used in the Store monad.+ This mimicks the case where unique IDs are used+ to look up a value in the environment.+ In this case, the environment is passed around by the Store monad.+------------------------------------------------------------------------------}+-- store monad+type Store = IO+-- references to observe sharing+type Ref a = IORef (Maybe a)++runStore :: Store a -> IO a+runStore = id++-- create a new reference. Dummy argument to prevent let floating+newRef :: b -> Ref a+-- read a reference. Only possible in the Store monad.+readRef :: Ref a -> Store (Maybe a)+writeRef :: Ref a -> a -> Store ()++newRef b = unsafePerformIO . seq [b] . newIORef $ Nothing+readRef = readIORef+writeRef ref = writeIORef ref . Just++-- invalid reference that may not store values+invalidRef = error "Store: invalidRef. This is an internal bug."++{-----------------------------------------------------------------------------+ Cache+------------------------------------------------------------------------------}+-- a cache stores values of different types+-- This is done with IORefs and a list of finalizerss+type Cache = [IO ()]++emptyCache = []++-- FIXME: add initializers to the Cache, so we can use it+-- like a data store!++-- monad to build the network in+type Compile = StateT Cache Store+-- monad to run the network in+type Run = IdentityT IO++runCompile :: Compile a -> Store (a, Cache)+runCompile m = runStateT m []++registerFinalizer :: IO () -> Compile ()+registerFinalizer m = modify $ (++[m])++runRun :: Run a -> Cache -> IO (a, Cache)+runRun m cache = do+ x <- runIdentityT m -- run the action+ sequence_ cache -- run all the finalizers+ return (x,cache) -- return dummy argument++-- a simple value to be cached. Lasts one phase.+type CacheRef a = IORef (Maybe a)++newCacheRef :: Compile (CacheRef a)+readCacheRef :: CacheRef a -> Run (Maybe a)+writeCacheRef :: CacheRef a -> a -> Run ()++newCacheRef = do+ ref <- liftIO $ newIORef Nothing+ registerFinalizer $ writeIORef ref Nothing+ return ref++readCacheRef = liftIO . readIORef+writeCacheRef ref = liftIO . writeIORef ref . Just++-- accumulation values+-- cache a value over several phases+type AccumRef a = IORef a++newAccumRef :: a -> Compile (AccumRef a)+updateAccum :: AccumRef a -> (a -> a) -> Run a++newAccumRef = liftIO . newIORef+updateAccum ref f = do+ x <- liftIO $ readIORef ref+ let !y = f x+ liftIO $ writeIORef ref y+ return y++-- behaviors+-- Cache a value over several phases,+-- but updates are only visible at the beginning of a new phase.+type BehaviorRef a = (IORef a, IORef a)++newBehaviorRef :: a -> Compile (BehaviorRef a)+readBehaviorRef :: BehaviorRef a -> Run a+updateBehaviorRef :: BehaviorRef a -> (a -> a) -> Run () -- Strict!++newBehaviorRef x = do+ ref <- liftIO $ newIORef x+ temp <- liftIO $ newIORef x+ registerFinalizer $ do+ x <- readIORef temp+ writeIORef ref x+ return (ref,temp)++readBehaviorRef (ref,temp) = liftIO $ readIORef ref++updateBehaviorRef (ref,temp) f = liftIO $ do+ x <- readIORef temp+ writeIORef temp $! f x -- strict!++{-----------------------------------------------------------------------------+ Abstract syntax tree+------------------------------------------------------------------------------}+data Accum+data Shared+data Linear++type EventStore a = [(Channel, CacheRef a)]++type family Event t a+type instance Event Accum a = (Ref (EventStore a), EventD Accum a)+type instance Event Shared a = (Ref (EventStore a), EventD Shared a)+type instance Event Linear a = EventD Linear a++data EventD t :: * -> * where+ Filter :: (a -> Bool) -> Event t a -> EventD t a+ ApplyE :: Behavior t (a -> b) -> Event t a -> EventD t b+ AccumE :: a -> Event t (a -> a) -> EventD t a+ Union :: Event t a -> Event t a -> EventD t a+ Never :: EventD t a+ + -- internal combinators+ Input :: Typeable a => Channel -> EventD t a+ Reactimate :: Event t (IO ()) -> EventD t ()+ + ReadCache :: Channel -> CacheRef a -> EventD t a+ WriteCache :: CacheRef a -> Event t a -> EventD t a+ + UpdateAccum :: AccumRef a -> Event t (a -> a) -> EventD t a+ WriteBehavior :: BehaviorRef a -> Event t (a -> a) -> EventD t ()+++type BehaviorStore a = BehaviorRef a++type family Behavior t a+type instance Behavior Accum a = (Ref (BehaviorStore a), BehaviorD Accum a)+type instance Behavior Shared a = (Ref (BehaviorStore a), BehaviorD Linear a)+type instance Behavior Linear a = (Ref (BehaviorStore a), BehaviorD Linear a)++data BehaviorD t a where+ Pure :: a -> BehaviorD t a+ ApplyB :: Behavior t (a -> b) -> Behavior t a -> BehaviorD t b+ AccumB :: a -> Event t (a -> a) -> BehaviorD t a+ + -- internal combinators+ ReadBehavior :: BehaviorRef a -> BehaviorD t a++{-----------------------------------------------------------------------------+ Dynamic types for input+------------------------------------------------------------------------------}+type Channel = Integer+type Universe = (Channel, Dynamic)++fromUniverse :: Typeable a => Channel -> Universe -> Maybe a+fromUniverse i (j,x) = if i == j then fromDynamic x else Nothing++toUniverse :: Typeable a => Channel -> a -> Universe+toUniverse i x = (i, toDyn x)++{-----------------------------------------------------------------------------+ Compilation+------------------------------------------------------------------------------}+-- replace every occurence of accumB with reading from a cached event+type CompileAccumB = WriterT [Event Shared ()] Compile++compileAccumB :: Event Accum () -> Compile (Event Shared ())+compileAccumB e1 = do+ (e,es) <- runWriterT (goE e1)+ -- include updates to Behavior as additional events+ return $ foldr1 union (e:es)+ where+ union e1 e2 = (invalidRef, Union e1 e2)+ + -- boilerplate traversal for events+ goE :: Event Accum a -> CompileAccumB (Event Shared a)+ goE (ref, Filter p e ) = (ref,) <$> (Filter p <$> goE e)+ goE (ref, Union e1 e2) = (ref,) <$> (Union <$> goE e1 <*> goE e2)+ goE (ref, ApplyE b e ) = (ref,) <$> (ApplyE <$> goB b <*> goE e )+ goE (ref, AccumE x e ) = (ref,) <$> (AccumE x <$> goE e)+ goE (ref, Reactimate e) = (ref,) <$> (Reactimate <$> goE e)+ goE (ref, Never) = (ref,) <$> (pure Never)+ goE (ref, Input c) = (ref,) <$> (pure $ Input c)+ + -- almost boilerplate traversal for behaviors+ goB :: Behavior Accum a -> CompileAccumB (Behavior Shared a)+ goB (ref, Pure x ) = (ref,) <$> (Pure <$> return x)+ goB (ref, ApplyB bf bx) = (ref,) <$> (ApplyB <$> goB bf <*> goB bx)+ goB (ref, AccumB x e ) = (ref,) <$> (ReadBehavior <$> makeRef)+ where+ makeRef = do+ m <- lift . lift $ readRef ref+ case m of+ Just r -> return r+ Nothing -> do+ r <- lift $ newBehaviorRef x+ -- immedately store the cached reference+ lift . lift $ writeRef ref r+ -- remove accumB from the other events+ e <- goE e+ tell [(invalidRef, WriteBehavior r e)]+ return r+++-- fan out unions into linear paths+type EventLinear a = (Channel, Event Linear a)++compileUnion :: Event Shared a -> Compile [Event Linear a]+compileUnion e = map snd <$> goE e+ where+ goE :: Event Shared a -> Compile [EventLinear a]+ goE (ref, Filter p e ) = cacheEvents ref (map2 (Filter p) <$> goE e)+ goE (ref, ApplyE b e ) = cacheEvents ref (map2 (ApplyE b) <$> goE e)+ goE (ref, AccumE x e ) = cacheEvents ref (compileAccumE x =<< goE e)+ goE (_ , WriteBehavior b e) = map2 (WriteBehavior b) <$> goE e+ goE (_ , Reactimate e) = map2 (Reactimate) <$> goE e+ goE (_ , Union e1 e2) = (++) <$> goE e1 <*> goE e2+ goE (_ , Never ) = return []+ goE (_ , Input channel) = return [(channel, Input channel)]+ + second f (a,b) = (a, f b)+ map2 = map . second+ + compileAccumE :: a -> [EventLinear (a -> a)] -> Compile [EventLinear a]+ compileAccumE x es = do+ ref <- newAccumRef x+ return $ map2 (UpdateAccum ref) es+ + cacheEvents :: Ref (EventStore a)+ -> Compile [EventLinear a] -> Compile [EventLinear a]+ cacheEvents ref mes = do+ m <- lift $ readRef ref+ case m of+ Just cached -> do+ return $ map (\(c,r) -> (c,ReadCache c r)) cached+ Nothing -> do+ -- compile input events+ es <- mes+ -- allocate corresponding cache references+ cached <- forM es $ \(c,_) -> do r <- newCacheRef; return (c,r)+ lift $ writeRef ref cached+ -- return events that also write to the cache+ return $ zipWith (second . (WriteCache . snd)) cached es++-- compile a behavior+-- FIXME: take care of sharing, caching+compileBehavior :: Behavior Linear a -> Run a+compileBehavior = goB+ where+ goB :: Behavior Linear a -> Run a+ goB (ref, Pure x) = return x+ goB (ref, ApplyB bf bx) = goB bf <*> goB bx+ goB (ref, ReadBehavior refb) = readBehaviorRef refb+++-- compile path into an IO action+type Path = (Channel, Universe -> Run ())++compilePath :: Event Linear () -> Path+compilePath e = goE e return+ where+ goE :: Event Linear a -> (a -> Run ()) -> (Channel, Universe -> Run ())+ goE (Filter p e) k = goE e $ \x -> when (p x) (k x)+ goE (ApplyE b e) k = goE e $ \x -> goB b >>= \f -> k (f x)+ goE (UpdateAccum ref e) k = goE e $ \f -> updateAccum ref f >>= k+ goE (WriteBehavior b e) _ = goE e $ \x -> updateBehaviorRef b x+ -- note: no k here because writing behaviors is the end of a path+ goE (Reactimate e) _ = goE e $ \x -> liftIO x+ goE (ReadCache c ref) k =+ (c, \_ -> readCacheRef ref >>= maybe (return ()) k)+ goE (WriteCache ref e) k = goE e $ \x -> writeCacheRef ref x >> k x+ goE (Input channel) k =+ (channel, maybe (error "wrong channel") k . fromUniverse channel)+ + goB = compileBehavior++-- compilation function+compile :: Event Accum () -> IO ([Path], Cache)+compile e = runStore $ runCompile $+ return . map compilePath =<< compileUnion =<< compileAccumB e++-- debug :: MonadIO m => String -> m ()+-- debug = liftIO . putStrLn++{-----------------------------------------------------------------------------+ Class instances+------------------------------------------------------------------------------}+data PushIO++-- type Behavior = Model.Behavior PushIO+newtype instance Model.Behavior PushIO a = Behavior (Behavior Accum a)++-- type Event = Model.Event PushIO+newtype instance Model.Event PushIO a = Event (Event Accum a)++unEvent (Event e) = e++-- sharing+behavior :: BehaviorD Accum a -> Model.Behavior PushIO a+behavior b = Behavior (ref, b)+ where+ {-# NOINLINE ref #-} + ref = newRef b++event :: EventD Accum a -> Model.Event PushIO a+event e = Event (ref, e)+ where+ {-# NOINLINE ref #-}+ ref = newRef e++-- boilerplate class instances+instance Functor (Model.Event PushIO) where+ fmap f e = apply (pure f) e+ +instance Applicative (Model.Behavior PushIO) where+ pure x = behavior $ Pure x+ (Behavior bf) <*> (Behavior bx) = behavior $ ApplyB bf bx++instance Functor (Model.Behavior PushIO) where+ fmap = liftA++instance FRP PushIO where+ never = event $ Never+ union (Event e1) (Event e2) = event $ Union e1 e2+ filter p (Event e) = event $ Filter p e+ apply (Behavior bf) (Event ex) = event $ ApplyE bf ex+ accumB x (Event e) = behavior $ AccumB x e+ accumE x (Event e) = event $ AccumE x e++
+ src/Reactive/Banana/Tests.hs view
@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+ Reactive Banana+ + Test cases and examples+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, NoMonomorphismRestriction #-}+module Reactive.Banana.Tests where++import Prelude hiding (filter)+import Control.Monad (when)++import Reactive.Banana.Model as Model+import Reactive.Banana.Implementation as Impl++import Test.QuickCheck++{-----------------------------------------------------------------------------+ Testing+------------------------------------------------------------------------------}+matchesModel :: (Typeable a, Show b, Eq b) =>+ (forall f. FRP f => Event f a -> Event f b) -> [a] -> IO Bool+matchesModel f = \xs -> do+ let bs1 = Model.run f xs+ bs2 <- Impl.run f xs+ when (bs1 /= bs2) $ print bs1 >> print bs2+ return $ bs1 == bs2++{-+testSuite = do+ -- TODO: algebraic laws+ -- larger examples+ quickCheck $ matchesModel decrease+ -}++{-----------------------------------------------------------------------------+ Examples+------------------------------------------------------------------------------}+test f = Impl.run f [1..8::Int]++add1 = fmap (+1)+filtering = filter (>= 3) . fmap (subtract 1)+counter e = apply (pure const <*> bcounter) e+ where bcounter = accumB 0 $ fmap (\_ -> (+1)) e+double e = union e e+sharing e = union e1 e1+ where e1 = filter (< 3) e++type Dummy = Int++-- counter that can be decreased as long as it's >= 0+decrease :: FRP f => Event f Dummy -> Event f Int+decrease edec = apply (const <$> bcounter) ecandecrease+ where+ bcounter = accumB 4 $ (subtract 1) <$ ecandecrease+ ecandecrease = whenE ((>0) <$> bcounter) edec++-- test accumE vs accumE+accumBvsE :: FRP f => Event f Dummy -> Event f Int+accumBvsE input = e1 `union` e2+ where+ e = input `union` input+ e1 = accumE 0 ((+1) <$ e)+ e2 = let b = accumB 0 ((+1) <$ e) in apply (const <$> b) e+
− src/Reactive/Classes.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{------------------------------------------------------------------------------ Reactive-Banana-------------------------------------------------------------------------------}-module Reactive.Classes (- -- $doc- ReactiveSyntax(..)- ) where--import Reactive.Core--{-$doc-This module provides a syntactically convenient 'accumulate' function.-This is an extra module because it uses type class extensions.--}---- | Convenient type class for automatically--- selecting the right 'accumulate' function by type.-class ReactiveSyntax b t where- accumulate :: (a -> b -> t) -> b -> Event a -> Behavior b--instance ReactiveSyntax b b where- accumulate = accumulate'-instance ReactiveSyntax b (Change b) where- accumulate = accumulateChange-instance ReactiveSyntax b (IO b) where- accumulate = accumulateIO-instance ReactiveSyntax b (IO (Change b)) where- accumulate = accumulateIOChange
− src/Reactive/Core.hs
@@ -1,520 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}--{------------------------------------------------------------------------------- TODO:- What should we do with the variants involving time-varying functions?- Should they get the same, or a different name?- - For example:- - map :: (a -> b) -> Event a -> Event b- apply :: Behavior (a -> b) -> Event a -> Event b - - filter :: (a -> Bool) -> Event a -> Event a- filterB :: Behavior (a -> Bool) -> Event a -> Event a --- accumulate doesn't need a Behavior variant!- -> accumulate ($) b $ apply behavior event-- TODO:- At some point, we probably need a function to dynamically switch- between events, something like this- - join :: Event (Event a) -> Event a-- Not sure about this particular functions,- but the point is that event handlers are being registered,- and also *unregisterered* while the program is running.- At the moment, everything is set up statically.--------------------------------------------------------------------------------}--module Reactive.Core (- -- * Events- -- $Event- Event, never, fromEventSource, reactimate,- mapIO, filter, filterChanges,- union, merge, orderedDuplicate,- traceEvent,- - -- * Behaviors- -- $Behavior- Behavior, behavior, always, initial, changes, apply,- accumulate', accumulateChange, accumulateIO, accumulateIOChange,- mapAccum,- - -- * The @Change@ data type- Change(..), isChange, isKeep,- - -- * Event Sources- -- $EventSource- EventSource(..), Prepare, newEventSource, fire,- - -- * Internal- testCounter, testApply- ) where--import Prelude hiding (map, filter)-import Control.Applicative-import Control.Monad-import Data.IORef-import Data.Maybe-import Data.Monoid-import System.IO.Unsafe-import System.IO--import Debug.Trace--{----------------------------------------------------------------------------- - Prepare-------------------------------------------------------------------------------}---- | The 'Prepare' monad is just a type synonym for 'IO'.--- The idea is that the event flow is set up in the 'Prepare' monad;--- all 'Prepare' actions should be called--- during the program initialization, but not while the event loop--- is running.-type Prepare a = IO a--{----------------------------------------------------------------------------- - EventSource - "I'll call you back"-------------------------------------------------------------------------------}-{-$EventSource- - After having read all about 'Event's and 'Behavior's,- you want to hook things up to an existing event-based framework,- like @wxHaskell@ or @Gtk2Hs@.- How do you do that?- - 'EventSource's are a small bookkeeping device that helps you with that.- Basically, they store event handlers. Often, you can just obtain them from- corresponding bookkeeping devices from your framework,- but sometimes you have to create your own 'EventSource'- and use the 'fire' function to hook it into the framework.- Event sources are also useful for testing.- - After creating an 'EventSource',- you can finally obtain an 'Event' via the `fromEventSource' function.--}----- | An 'EventSource' is a facility where you can register--- callback functions, aka event handlers.--- 'EventSource's are the precursor of proper 'Event's.-data EventSource a = EventSource {- -- | Replace all event handlers by this one.- setEventHandler :: (a -> IO ()) -> Prepare ()- -- | Retrieve the currently registered event handler.- , getEventHandler :: Prepare (a -> IO ()) }---- add an additional event handler to the source-addEventHandler :: EventSource a -> (a -> IO ()) -> Prepare ()-addEventHandler es f = do- g <- getEventHandler es- setEventHandler es (\a -> g a >> f a)----- | Fire the event handler of an event source manually.--- Useful for hooking into external event sources.-fire :: EventSource a -> a -> IO ()-fire es a = getEventHandler es >>= ($ a)- -- here, the purpose of the Prepare monad is intentionally violated---- | Create a new store for callback functions.--- They have to be fired manually with the 'fire' function.-newEventSource :: Prepare (EventSource a)-newEventSource = do- handlerRef <- newIORef (const $ return ())- return $ EventSource- { setEventHandler = writeIORef handlerRef- , getEventHandler = readIORef handlerRef }--{------------------------------------------------------------------------------ Event-------------------------------------------------------------------------------}-{-$Event--The 'Event' type constructor is one of the cornerstones of the present-approach to functional reactive programmings.-It represents a stream of values as they occur in time.---}----- who would have thought that the implementation is this simple-type AddHandler a = (a -> IO ()) -> Prepare ()--{- | @Event a@ represents a stream of events as they occur in time.-Semantically, you can think of @Event a@ as an infinite list of values-that are tagged with their corresponding time of occurence,--> type Event a = [(Time,a)]--Note that this is a semantic model;-the type is not actually implement that way,-but you can often treat it as if it where.-In particular, most of the subsequent operations-will be explained in terms of this model.---}-data Event a = Never- | Event { addHandler :: AddHandler a }---- smart constructor, ensures proper sharing-mkEvent :: AddHandler a -> Event a-mkEvent =- -- What happens when unsafePerformIO is accidentally exectued twice?- -- In that case, work will be duplicated as there will be two- -- buffers (event sources) for one and the same event.- -- But this is the same as the situation without any sharing at all,- -- so there's no harm done.- -- There might be a problem with executing IO actions twice, though.- \h -> unsafePerformIO $ share $ Event { addHandler = h }- where- -- Cache the value of an event,- -- so that it's not recalculated for multiple consumers- share :: Event a -> Prepare (Event a)- share e1 = do- es2 <- newEventSource- addHandler e1 (fire es2) -- sharing happens through call-by-need- return $ fromEventSource es2---- | Derive an 'Event' from an 'EventSource'.--- Apart from 'never', this is the only way to construct events.-fromEventSource :: EventSource a -> Event a-fromEventSource s = Event { addHandler = addEventHandler s }---- | Schedule an IO event to be executed whenever it happens.--- This is the only way to observe events.--- Semantically, you could write it as something like this------ > reactimate ((time,action):es) = atTime time action >> reactimate es --- --- The 'Prepare' monad indicates that you should call this function--- during program initialization only.-reactimate :: Event (IO ()) -> Prepare ()-reactimate Never = return ()-reactimate e = addHandler e id---- | The value 'never' denotes the event that never happens.--- We can model it as the empty stream of events, @never = []@.-never :: Event a-never = Never---- | The 'Functor' instance allows you to map the values of type 'a'.--- Semantically,--- --- > fmap f ((time,a):es) = (time, f a) : fmap f es-instance Functor Event where- fmap f Never = Never- fmap f e = mkEvent addHandler'- where addHandler' g = addHandler e (g . f)---- | Version of 'fmap' that performs an 'IO' action for each event occurence.-mapIO :: (a -> IO b) -> Event a -> Event b-mapIO f Never = Never-mapIO f e = mkEvent addHandler'- where addHandler' g = addHandler e (g <=< f)----- | Merge two event streams of the same type. Semantically, we have--- --- > union ((time1,a1):es1) ((time2,a2):es2)--- > | time1 < time2 = (time1,a1) : union es1 ((time2,a2):es2)--- > | time1 > time2 = (time2,a2) : union ((time1,a1):es1) es2--- > | otherwise = ... -- either of the previous two cases--- --- Note that the order of events that happen simultaneously is /undefined/.--- This is not a problem most of the time,--- but sometimes you have to force a certain order.--- In that case, you have to combine this with the 'orderedDuplicate' function. -union :: Event a -> Event a -> Event a-union Never e2 = e2-union e1 Never = e1-union e1 e2 = mkEvent addHandler'- where addHandler' g = addHandler e1 g >> addHandler e2 g---- | The 'Monoid' instance allows you to merge event streams,--- see the 'union' function below.--- --- > mempty = never--- > mappend = union-instance Monoid (Event a) where- mempty = never- mappend = union---- | Merge two event streams that have differen types. Semantically, we have--- --- > merge e1 e2 = fmap Left e1 `union` fmap Right e2-merge :: Event a -> Event b -> Event (Either a b)-merge e1 e2 = fmap Left e1 `union` fmap Right e2----- | Duplicate an event stream while paying attention to ordering.--- Events from the first duplicate (and anything derived from them)--- will always happen--- before the events from the second duplicate.--- Use this function to fine-tune the order of events.-orderedDuplicate :: Event a -> (Event a, Event a)-orderedDuplicate Never = (never, never)-orderedDuplicate e =- unsafePerformIO $ do -- should be safe, though, only for sharing- es1 <- newEventSource- es2 <- newEventSource- addHandler e $ \a -> fire es1 a >> fire es2 a- return (fromEventSource es1, fromEventSource es2)---- | Pass all events that fulfill the predicate, discard the rest. Semantically,--- --- > filter p es = [(time,a) | (time,a) <- es, p a]-filter :: (a -> Bool) -> Event a -> Event a-filter p Never = Never-filter p e = mkEvent addHandler'- where addHandler' g = addHandler e $ \a -> when (p a) (g a)---- | Unpacks event values of the form @Change _@ and discards--- everything else.-filterChanges :: Event (Change a) -> Event a-filterChanges = fmap (\(Change x) -> x) . filter isChange----- | Debugging helper. Prints the first argument and the value of the event--- whenever it happens to 'stderr'.-traceEvent :: Show a => String -> Event a -> Event a-traceEvent s = mapIO (\a -> hPutStrLn stderr (s ++ " : " ++ show a) >> return a)--{------------------------------------------------------------------------------ Behavior-------------------------------------------------------------------------------}-{--FIXME: exporting initial to users might cause space leaks-where the initial value is retained long beyond the point where-it was consumed.-However, if we want the user to implement optimized behaviors-himself, like TimeGraphic , we have to provide a mechanism-similar to this one.-Alternative: keep current value in a IORef. This will eliminate-this particular space leak? Probably not. I think it's fine the way it is.--}--{-$Behavior--The 'Behavior' type constructor is the other cornerstone of the-present approach to functional reactive programming.-It represents a value that changes with time.---}--{-| @Behavior a@ represents a value in time. Think of it as--> type Behavior a = Time -> a--However, note that this model misses an important point:-we only allow /piecewise constant/ functions.-Continuous behaviors like--> badbehavior = \time -> 2*time--cannot be implemented.---}-data Behavior a = Behavior {- initial :: a, -- ^ The value that the behavior initially has.- changes :: Event a- -- ^ An event stream recording how the behavior changes- -- Remember that behaviors are piecewise constant functions.- }---- | Smart constructor. Supply an initial value and a sequence of changes.--- In particular,--- --- > initial (behavior a es) = a--- > changes (behavior a es) = es-behavior :: a -> Event a -> Behavior a-behavior = Behavior---- | The constant behavior. Semantically,--- --- > always a = \time -> a-always :: a -> Behavior a-always a = Behavior { initial = a, changes = never }-- -- trigger an event whenever the value changes.--- changes :: Behavior a -> Event a---- | Version of 'accumulate' that involves the 'Change' data type--- and performs an 'IO' action to update the value.--- --- It is recommended that you use the 'accumulate' function from--- 'Reactive.Classes' to pick types automatically.-accumulateIOChange :: (b -> a -> IO (Change a)) -> a -> Event b -> Behavior a-accumulateIOChange f a Never = always a-accumulateIOChange f a eb =- Behavior { initial = a , changes = mkEvent addHandler' }- where- addHandler' g = addHandler eb (handler g)- - -- we need a global state- -- FIXME: NOINLINE pragma!- ref = unsafePerformIO $ newIORef a- handler g = \b -> do- a <- readIORef ref -- read old value- ma' <- f b a -- accumulate- case ma' of- Keep -> return ()- Change a' -> do- writeIORef ref $! a' -- use new value- g a'--{- | The most important way to create behaviors.-The 'accumulate'' function is similar to a strict left fold, 'foldl''.-It starts with an initial value and combines it with incoming events.-For example, semantically- -> accumulate' (++) "x" [(time1,"y"),(time2,"z")]-> = behavior "x" [(time1,"yx"),(time2,"zyx")]- -Note that the accumulated value is evaluated /strictly/.-This prevents space leaks.--It is recommended that you use the 'accumulate' function from-'Reactive.Classes' to pick types automatically.--}-accumulate' :: (b -> a -> a) -> a -> Event b -> Behavior a-accumulate' f = accumulateIOChange (\b a -> return . Change $ f b a)---- | Version of 'accumulate' that involves the 'Change' data type.--- Use the 'Keep' constructor to indicate that the incoming event --- hasn't changed the value. No change event will be propagated in that case.--- --- It is recommended that you use the 'accumulate' function from--- 'Reactive.Classes' to pick types automatically.-accumulateChange :: (b -> a -> Change a) -> a -> Event b -> Behavior a-accumulateChange f = accumulateIOChange (\b a -> return $ f b a)----- | Version of 'accumulate' that performs an 'IO' action to update the value.--- --- It is recommended that you use the 'accumulate' function from--- 'Reactive.Classes' to pick types automatically.-accumulateIO :: (b -> a -> IO a) -> a -> Event b -> Behavior a-accumulateIO f = accumulateIOChange (\b a -> fmap Change $ f b a)- -- Note: IO would be unsound without sharing!----- | The 'Functor' instance allows you to map the values of type @a@.--- Semantically, --- --- > fmap f behavior = \time -> f (behavior time)-instance Functor Behavior where- fmap f b = Behavior- { initial = f (initial b), changes = fmap f (changes b) }---- | The 'Applicative' instance is one most of the most important ways--- to combine behaviors. Semantically,--- --- > pure a = always a--- > bf <*> bx = \time -> bf time $ bx time -instance Applicative Behavior where- pure a = always a- - -- optimize the cases where the event never fires- (Behavior f Never) <*> bx = fmap (f $) bx- bf <*> (Behavior x Never) = fmap ($ x) bf- bf <*> bx = fmap (uncurry ($)) $- accumulate' go (initial bf, initial bx) (changes bf `merge` changes bx)- where- go (Left f') (f,x) = (f',x)- go (Right x') (f,x) = (f,x')-- -- store the occurences of an event in a behavior--- latch :: Event a -> Behavior (Maybe a)--- latch = accumulate' (\a _ -> Just a) Nothing---- | Map events while threading state.--- Similar to the standard 'mapAccumL' function.-mapAccum :: (acc -> x -> (acc,y)) -> acc -> Event x -> (Behavior acc, Event y)-mapAccum f acc Never = (always acc, never) -mapAccum f acc xs =- (fmap fst result, fmap snd $ changes result)- where- result = accumulate' (\x (acc,_) -> f acc x) (acc,undefined) xs---- | The most important way to combine behaviors and events.--- The 'apply' function applies a time-varying function to a stream of events.--- Semantically,--- --- > apply bf es = [(time, bf time a) | (time, a) <- es]--- --- (Theoretically inclined people might--- be wondering whether we could achieve the same effect with--- the 'Applicative' instance. The answer is no, the semantics of--- 'apply' and '<*>' are subtly different. That's why we need to distinguish--- between behaviors and events.)-apply :: Behavior (a -> b) -> Event a -> Event b-apply (Behavior f Never) ex = fmap f ex-apply bf Never = Never-apply bf ex =- filterChanges . snd . mapAccum go (initial bf) $ changes bf `merge` ex- where- go _ (Left f) = (f, Keep)- go f (Right x) = (f, Change $ f x)--{------------------------------------------------------------------------------ Change-------------------------------------------------------------------------------}-{- | Data type to indicate that a value has changed.-Used in conjunction with the 'accumulate' functions.--This is basically the @Maybe@ type with a different name.-Using a different name improves program readability-and makes it easier to automatically select the right 'accumulate'-function by type, see the 'Reactive.Classes' module.--}-data Change a =- Keep -- ^ Signals that the value has not changed.- | Change a -- ^ Indicates a change to some value of type @a@.- deriving (Eq, Show, Read)--instance Functor Change where- fmap _ Keep = Keep- fmap f (Change a) = Change (f a)---- | The 'isChange' function returns 'True' iff its argument is of the form @Change _@.-isChange :: Change a -> Bool-isChange (Change _) = True-isChange _ = False---- | The 'isKeep' function returns 'True' iff its argument is of the form @Keep@.-isKeep :: Change a -> Bool-isKeep Keep = True-isKeep _ = False--{------------------------------------------------------------------------------ Test examples- - The examples return event sources that you can fire.-------------------------------------------------------------------------------}-testCounter :: Prepare (EventSource Int)-testCounter = do- es <- newEventSource- let e = fromEventSource es- reactimate . changes $ print <$> accumulate' (+) 0 e- return es---- test the apply function-testApply :: Prepare (EventSource Int, EventSource Int)-testApply = do- es1 <- newEventSource- let e1 = fromEventSource es1- - es2 <- newEventSource- let e2 = fromEventSource es2-- reactimate . fmap print $ apply (fmap (+) (Behavior 0 e1)) e1- return (es1, es2)-