diff --git a/reactive-banana.cabal b/reactive-banana.cabal --- a/reactive-banana.cabal +++ b/reactive-banana.cabal @@ -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 + diff --git a/src/Reactive.hs b/src/Reactive.hs deleted file mode 100644 --- a/src/Reactive.hs +++ /dev/null @@ -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 diff --git a/src/Reactive/Banana.hs b/src/Reactive/Banana.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana.hs @@ -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 diff --git a/src/Reactive/Banana/Implementation.hs b/src/Reactive/Banana/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Implementation.hs @@ -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 diff --git a/src/Reactive/Banana/Model.hs b/src/Reactive/Banana/Model.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Model.hs @@ -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) + diff --git a/src/Reactive/Banana/PushIO.hs b/src/Reactive/Banana/PushIO.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/PushIO.hs @@ -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 + + diff --git a/src/Reactive/Banana/Tests.hs b/src/Reactive/Banana/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Tests.hs @@ -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 + diff --git a/src/Reactive/Classes.hs b/src/Reactive/Classes.hs deleted file mode 100644 --- a/src/Reactive/Classes.hs +++ /dev/null @@ -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 diff --git a/src/Reactive/Core.hs b/src/Reactive/Core.hs deleted file mode 100644 --- a/src/Reactive/Core.hs +++ /dev/null @@ -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) -