reactive-banana 0.3.0.1 → 0.4.0.0

raw patch · 10 files changed

+405/−222 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• doc/examples/ActuatePause.hs +77/−0
• doc/examples/RunPause.hs +0/−77
• doc/examples/SlotMachine.hs +1/−1
• reactive-banana.cabal +4/−2
• src/Reactive/Banana.hs +8/−5
• src/Reactive/Banana/Implementation.hs +64/−25
• src/Reactive/Banana/Incremental.hs +110/−0
• src/Reactive/Banana/Model.hs +2/−2
• src/Reactive/Banana/PushIO.hs +122/−105
• src/Reactive/Banana/Tests.hs +17/−5

@@ -0,0 +1,77 @@+{-----------------------------------------------------------------------------+    reactive-banana+    +    Example: Actuate and pause an event network+------------------------------------------------------------------------------}+import Control.Monad (when)+import Data.Maybe (isJust, fromJust)+import Data.List (nub)+import System.Random+import System.IO+import Debug.Trace+import Data.IORef++import Reactive.Banana as R+++main :: IO ()+main = do+    displayHelpMessage+    sources <- (,) <$> newAddHandler <*> newAddHandler+    network <- setupNetwork sources+    actuate network+    eventLoop sources network++displayHelpMessage :: IO ()+displayHelpMessage = mapM_ putStrLn $+    "Commands are:":+    "   count   - send counter event":+    "   pause   - pause event network":+    "   actuate - actuate event network":+    "   quit    - quit the program":+    "":+    []++-- Read commands and fire corresponding events +eventLoop :: (EventSource (),EventSource EventNetwork) -> EventNetwork -> IO ()+eventLoop (escounter, espause) network = loop+    where+    loop = do+        putStr "> "+        hFlush stdout+        s <- getLine+        case s of+            "count"   -> fire escounter ()+            "pause"   -> fire espause network+            "actuate" -> actuate network+            "quit"    -> return ()+            _         -> putStrLn $ s ++ " - unknown command"+        when (s /= "quit") loop++{-----------------------------------------------------------------------------+    Event sources+------------------------------------------------------------------------------}+-- Event Sources - allows you to register event handlers+-- Your GUI framework should provide something like this for you+type EventSource a = (AddHandler a, a -> IO ())++addHandler :: EventSource a -> AddHandler a+addHandler = fst++fire :: EventSource a -> a -> IO ()+fire = snd++{-----------------------------------------------------------------------------+    Program logic+------------------------------------------------------------------------------}+-- Set up the program logic in terms of events and behaviors.+setupNetwork :: (EventSource (),EventSource EventNetwork) -> IO EventNetwork+setupNetwork (escounter, espause) = compile $ do+    ecounter <- fromAddHandler (addHandler escounter)+    epause   <- fromAddHandler (addHandler espause  )+    +    let ecount = accumE 0 ((+1) <$ ecounter)+    +    reactimate $ fmap print ecount+    reactimate $ fmap pause epause+

@@ -1,77 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-    -    Example: Run and pause an event network-------------------------------------------------------------------------------}-import Control.Monad (when)-import Data.Maybe (isJust, fromJust)-import Data.List (nub)-import System.Random-import System.IO-import Debug.Trace-import Data.IORef--import Reactive.Banana as R---main :: IO ()-main = do-    displayHelpMessage-    sources <- (,) <$> newAddHandler <*> newAddHandler-    network <- setupNetwork sources-    run network-    eventLoop sources network--displayHelpMessage :: IO ()-displayHelpMessage = mapM_ putStrLn $-    "Commands are:":-    "   count   - send counter event":-    "   pause   - pause event network":-    "   run     - run   event network":-    "   quit    - quit the program":-    "":-    []---- Read commands and fire corresponding events -eventLoop :: (EventSource (),EventSource EventNetwork) -> EventNetwork -> IO ()-eventLoop (escounter, espause) network = loop-    where-    loop = do-        putStr "> "-        hFlush stdout-        s <- getLine-        case s of-            "count" -> fire escounter ()-            "pause" -> fire espause network-            "run"   -> run network-            "quit"  -> return ()-            _       -> putStrLn $ s ++ " - unknown command"-        when (s /= "quit") loop--{------------------------------------------------------------------------------    Event sources-------------------------------------------------------------------------------}--- Event Sources - allows you to register event handlers--- Your GUI framework should provide something like this for you-type EventSource a = (AddHandler a, a -> IO ())--addHandler :: EventSource a -> AddHandler a-addHandler = fst--fire :: EventSource a -> a -> IO ()-fire = snd--{------------------------------------------------------------------------------    Program logic-------------------------------------------------------------------------------}--- Set up the program logic in terms of events and behaviors.-setupNetwork :: (EventSource (),EventSource EventNetwork) -> IO EventNetwork-setupNetwork (escounter, espause) = compile $ do-    ecounter <- fromAddHandler (addHandler escounter)-    epause   <- fromAddHandler (addHandler espause  )-    -    let ecount = accumE 0 ((+1) <$ ecounter)-    -    reactimate $ fmap print ecount-    reactimate $ fmap pause epause-

@@ -19,7 +19,7 @@     displayHelpMessage     sources <- makeSources     network <- setupNetwork sources-    run network+    actuate network     eventLoop sources  displayHelpMessage :: IO ()

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.3.0.1+Version:             0.4.0.0 Synopsis:            Small but solid library for                      functional reactive programming (FRP). Description:         @@ -52,7 +52,9 @@         base >= 4.2 && < 4.4, containers == 0.4.*,         monads-tf == 0.1.*, transformers == 0.2.*,         QuickCheck == 2.4.*-    exposed-modules:    Reactive.Banana, Reactive.Banana.Model,+    exposed-modules:    Reactive.Banana,+                        Reactive.Banana.Incremental,+                        Reactive.Banana.Model,                         Reactive.Banana.Implementation,                         Reactive.Banana.Tests     other-modules:      Reactive.Banana.PushIO,

@@ -5,16 +5,19 @@ ------------------------------------------------------------------------------}  module Reactive.Banana (+    module Reactive.Banana.Incremental,     module Reactive.Banana.Model,     module Reactive.Banana.Implementation, -    Event, Behavior+    Event, Behavior, Discrete,     ) where +import Reactive.Banana.Incremental hiding (Discrete)+import qualified Reactive.Banana.Incremental as Polymorph import Reactive.Banana.Model hiding (interpret, Event, Behavior)-import qualified Reactive.Banana.Model as Model+import qualified Reactive.Banana.Model as Polymorph import Reactive.Banana.Implementation-import qualified Reactive.Banana.Implementation as Implementation -type Event = Model.Event PushIO-type Behavior = Model.Behavior PushIO+type Event    = Polymorph.Event PushIO+type Behavior = Polymorph.Behavior PushIO+type Discrete = Polymorph.Discrete PushIO

@@ -2,25 +2,26 @@ {-----------------------------------------------------------------------------     Reactive Banana     -    Linking any implementation to an event-based framework+    Linking the push-based implementation to an event-based framework ------------------------------------------------------------------------------} module Reactive.Banana.Implementation (     -- * Synopsis     -- | Build event networks using existing event-based frameworks     --   and run them.     -    -- * Implementation-    PushIO, interpret,+    -- * Simple use+    PushIO, interpret, interpretAsHandler, -    -- * Building event networks with input and output+    -- * Building event networks with input/output     -- $build     NetworkDescription, compile,-    AddHandler, fromAddHandler, reactimate, liftIO,+    AddHandler, fromAddHandler, fromPoll, reactimate, liftIO,          -- * Running event networks-    EventNetwork, run, pause,+    EventNetwork, actuate, pause,          -- * Utilities+    -- $utilities     newAddHandler,          module Data.Dynamic,@@ -28,7 +29,6 @@  import Reactive.Banana.PushIO hiding (compile) import qualified Reactive.Banana.PushIO as Implementation--- import Reactive.Banana.Model hiding (Event, Behavior, run) import qualified Reactive.Banana.Model as Model  import Control.Applicative@@ -47,6 +47,9 @@ ------------------------------------------------------------------------------} type Flavor  = Implementation.PushIO +poll :: IO a -> Model.Behavior Flavor a+poll = behavior . Poll+ input :: Typeable a => Channel -> Model.Event Flavor a input = event . Input @@ -98,7 +101,7 @@     describe the inputs, outputs and event graph in the 'NetworkDescription' monad      and use the 'compile' function to obtain an event network from that. -    To /run/ an event network, use the 'run' function.+    To /activate/ an event network, use the 'actuate' function.     The network will register its input event handlers and start producing output.      A typical setup looks like this:@@ -111,9 +114,12 @@ >   -- build the event network >   network <- compile $ do >       -- input: obtain  Event  from functions that register event handlers->       emouse    <- fromAddHandler (registerMouseEvent window)->       ekeyboard <- fromAddHandler (registerKeyEvent window)->   +>       emouse    <- fromAddHandler $ registerMouseEvent window+>       ekeyboard <- fromAddHandler $ registerKeyEvent window+>       -- input: obtain  Behavior  from mutable data by polling+>       btext     <- fromPoll       $ getTextValue editBox+>       bdie      <- fromPoll       $ randomRIO (1,6)+> >       -- express event graph >       let >           behavior1 = accumB ...@@ -125,7 +131,7 @@ >       reactimate $ fmap drawCircle eventCircle > >   -- register handlers and start producing outputs->   run network+>   actuate network      In short, you use 'fromAddHandler' to obtain /input/ events.     The library uses this to register event handlers@@ -180,7 +186,7 @@ -- | Input, -- obtain an 'Event' from an 'AddHandler'. ----- When the event network is run,+-- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called. fromAddHandler :: Typeable a => AddHandler a -> NetworkDescription (Model.Event PushIO a)@@ -192,8 +198,23 @@     where     newChannel = do c <- get; put $! c+1; return c +-- | Input,+-- obtain a 'Behavior' by polling mutable data, like mutable variables or GUI widgets.+-- +-- Ideally, the argument IO action just polls a mutable variable,+-- it should not perform expensive computations.+-- Neither should its side effects affect the event network significantly.+-- +-- Internally, the event network will take a snapshot of each mutable+-- datum before processing an input event, so that the obtained behavior+-- is well-defined. This snapshot is guaranteed to happen before+-- any 'reactimate' is performed. The network may omit taking a snapshot altogether+-- if the behavior is not needed.+fromPoll :: IO a -> NetworkDescription (Model.Behavior PushIO a)+fromPoll m = return $ poll m+ -- | Compile a 'NetworkDescription' into an 'EventNetwork'--- that you can 'run', 'pause' and so on.+-- that you can 'actuate', 'pause' and so on. compile :: NetworkDescription () -> IO EventNetwork compile (Prepare m) = do     (_,_,(outputs,inputs)) <- runRWST m () 0@@ -217,10 +238,10 @@ -- | Data type that represents a compiled event network. -- It may be paused or already running. data EventNetwork = EventNetwork {-    -- | Run an event network.+    -- | Actuate an event network.     -- The inputs will register their event handlers, so that     -- the networks starts to produce outputs in response to input events.-    run :: IO (),+    actuate :: IO (),          -- | Pause an event network.     -- Immediately stop producing output and@@ -228,7 +249,7 @@     -- Hence, the network stops responding to input events,     -- but it's state will be preserved.     ---    -- You can resume the network with 'run'.+    -- You can resume the network with 'actuate'.     --     -- Note: You can stop a network even while it is processing events,     -- i.e. you can use 'pause' as an argument to 'reactimate'.@@ -243,13 +264,13 @@     let nop = return ()     unregister <- newIORef nop     let-        run   = register >>= writeIORef unregister-        pause = readIORef unregister >>= id >> writeIORef unregister nop-    return $ EventNetwork run pause+        actuate = register >>= writeIORef unregister+        pause   = readIORef unregister >>= id >> writeIORef unregister nop+    return $ EventNetwork actuate pause   {------------------------------------------------------------------------------    Interpreter for testing+    Simple use ------------------------------------------------------------------------------} -- | Simple way to run an event graph. Very useful for testing. interpret :: Typeable a@@ -261,7 +282,7 @@         e <- fromAddHandler addHandler         reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) -    run network+    actuate network     bs <- forM xs $ \x -> do         runHandlers x         bs <- readIORef output@@ -269,14 +290,32 @@         return bs     return bs +-- | Simple way to write a single event handler with functional reactive programming.+interpretAsHandler :: Typeable a+    => (Model.Event PushIO a -> Model.Event PushIO b)+    -> AddHandler a -> AddHandler b+interpretAsHandler f addHandlerA = \handlerB -> do+    network <- compile $ do+        e <- fromAddHandler addHandlerA+        reactimate $ handlerB <$> f e+    actuate network+    return (pause network)  {-----------------------------------------------------------------------------     Utilities ------------------------------------------------------------------------------}+{-$utilities++    This section collects a few convenience functions+    for unusual use cases. For instance:+    +    * The event-based framework you want to hook into is poorly designed+    +    * You have to write your own event loop and roll a little event framework++-}+ -- | Build a facility to register and unregister event handlers.--- --- This function is only useful if you want to hook up this library--- to a poorly designed event-based framework, or roll your own. newAddHandler :: IO (AddHandler a, a -> IO ()) newAddHandler = do     handlers <- newIORef Map.empty

@@ -0,0 +1,110 @@+{-----------------------------------------------------------------------------+    Reactive Banana+    +    Derived data type, a hybrid between  Event  and  Behavior+------------------------------------------------------------------------------}+module Reactive.Banana.Incremental (+    -- * Why a third type Discrete?+    -- $discrete+    +    -- * Discrete time-varying values+    Discrete, initial, changes, value, stepperD,+    accumD, applyD,+    ) where++import Control.Applicative+import Reactive.Banana.Model++{-----------------------------------------------------------------------------+    Data Type+------------------------------------------------------------------------------}+{-$discrete++In an ideal world, users of functional reactive programming would+only need to use the notions of 'Behavior' and 'Event',+the first corresponding to value that vary in time+and the second corresponding to a stream of event ocurrences.++However, there is the problem of /incremental updates/.+Ideally, users would describe, say, the value of a GUI text field+as a 'Behavior' and the reactive-banana implementation would figure+out how to map this onto the screen without needless redrawing.+In other words, the screen should only be updated when the behavior changes.++While this would be easy to implement in simple cases,+it may not always suit the user;+there are many different ways of implementing+/incremental computations/.+But I don't know a unified theory for them, so+I have decided that the reactive-banana will give /explicit control over updates to the user/+in the form of specialized data types like 'Discrete',+and shall not attempt to bake experimental optimizations into the 'Behavior' type.++To sum it up:++* You get explicit control over updates (the 'changes' function),++* but you need to learn a third data type 'Discrete', which almost duplicates the 'Behavior' type.++* Even though the type 'Behavior' is more fundamental,+you will probably use 'Discrete' more often.++That said, 'Discrete' is not a new primitive type, but built from exising types and combinators; you are encouraged to look at the source code.++If you are an FRP implementor, I encourage you to find a better solution.+But if you are a user, you may want to accept the trade-off for now.++-}++-- | Like 'Behavior', the type 'Discrete' denotes a value that varies in time.+-- However, unlike 'Behavior',+-- it also provides a stream of events that indicate when the value has changed.+-- In other words, we can now observe updates.+data Discrete f a = D {+        -- | Initial value.+        initial :: a,+        -- | Event that records when the value changes.+        -- Simultaneous events may be pruned for efficiency reasons.+        changes :: Event f a,+        -- | Behavior corresponding to the value. It is always true that+        -- +        -- > value x = stepper (initial x) (changes x)+        value   :: Behavior f a+        }++-- | Construct a discrete time-varying value from an initial value and +-- a stream of new values.+stepperD :: FRP f => a -> Event f a -> Discrete f a+stepperD x e = D { initial = x, changes = calm e, value = stepper x e}+    where+    -- in case of simultaneous occurence: keep only the last event?+    calm = id++-- | Accumulate a stream of events into a discrete time-varying value.+accumD :: FRP f => a -> Event f (a -> a) -> Discrete f a+accumD x = stepperD x . accumE x++-- | Apply a discrete time-varying value to a stream of events.+-- +-- > applyD = apply . value+applyD :: FRP f => Discrete f (a -> b) -> Event f a -> Event f b+applyD = apply . value++-- | Functor instance+instance FRP f => Functor (Discrete f) where+    fmap f r = stepperD (f $ initial r) $ fmap f (changes r)++-- | Applicative instance+instance FRP f => Applicative (Discrete f) where+    pure x    = D { initial = x, changes = never, value = pure x }+    df <*> dx = stepperD b e+        where+        b = initial df $ initial dx+        e = uncurry ($) <$> pairs+        pairs = accumE (initial df, initial dx) $+            (left <$> changes df) `union` (right <$> changes dx)+        +        left  f (_,x) = (f,x)+        right x (f,_) = (f,x)++    

@@ -8,12 +8,12 @@     -- * Synopsis     -- | Combinators for building event networks and their semantics.     -    -- * Combinators+    -- * Core Combinators     module Control.Applicative,     FRP(..),-         Event, Behavior,     -- $classes+    -- * Derived Combinators     whenE, mapAccum,          -- * Model implementation

@@ -15,15 +15,14 @@   import Control.Applicative-import Data.Monoid- import Control.Monad.Trans.Identity import Control.Monad.State import Control.Monad.Writer-+import Data.Dynamic import Data.IORef+import Data.Maybe+import Data.Monoid import System.IO.Unsafe-import Data.Dynamic  {-----------------------------------------------------------------------------     Observable sharing@@ -59,43 +58,49 @@ ------------------------------------------------------------------------------} -- A cache stores values of different types -- and finalizers to change them.-data Cache = Cache { vault :: Vault, finalizers :: [Finalizer] }-type Finalizer = Vault -> IO Vault+data Cache = Cache {+              vault :: Vault+            , initializers :: [VaultChanger]+            , finalizers   :: [VaultChanger] }+type VaultChanger = Run () -emptyCache = Cache Vault.empty []+emptyCache :: Cache+emptyCache = Cache Vault.empty [] []  -- monad to build the network in type Compile = StateT Cache Store -- monad to run the network in-type Run     = StateT Cache IO+type Run     = StateT Vault IO  runCompile :: Compile a -> Store (a, Cache)-runCompile m = runStateT m $ Cache { vault = Vault.empty, finalizers = [] }--registerFinalizer :: Finalizer -> Compile ()-registerFinalizer m = modify $-    \cache -> cache { finalizers = finalizers cache ++ [m] }+runCompile m = runStateT m $ Cache { vault = Vault.empty, initializers = [], finalizers = [] } -runFinalizers :: [Finalizer] -> Vault -> IO Vault-runFinalizers = foldr (>=>) return+registerInitializer, registerFinalizer :: VaultChanger -> Compile ()+registerFinalizer m   = modify $+    \cache -> cache { finalizers   = finalizers cache ++ [m] }+registerInitializer m = modify $+    \cache -> cache { initializers = initializers cache ++ [m] }  runRun :: Run a -> Cache -> IO (a, Cache) runRun m cache = do-    -- run the action-    (x,cache') <- runStateT m cache   -    -- run all the finalizers              -    vault' <- runFinalizers (finalizers cache') (vault cache')-    -- return new cache-    return (x,cache' { vault = vault'})+        let vault1 = vault cache+        -- run the initializers+        vault2     <- runVaultChangers (initializers cache) vault1+        -- run the action+        (x,vault3) <- runStateT m vault2+        -- run all the finalizers              +        vault4     <- runVaultChangers (finalizers cache) vault3+        -- return new cache+        return (x,cache{ vault = vault4 })+    where+    runVaultChangers = execStateT . sequence_ --- helper functions for reading and writing keys into  vault cache-writeCacheKey ref x = do-    cache <- get-    vault' <- liftIO $ Vault.insert ref x (vault cache)-    put $ cache { vault = vault' }-readCacheKey ref = do-    cache <- get-    liftIO $ Vault.lookup ref (vault cache)+-- helper functions for reading and writing keys into the vault cache+writeVaultKey ref x = do+    vault  <- get+    vault' <- liftIO $ Vault.insert ref x vault+    put $ vault'+readVaultKey ref = liftIO . Vault.lookup ref =<< get  {-----------------------------------------------------------------------------     Cache, particular reference types@@ -110,53 +115,55 @@  newCacheRef      = do     key <- liftIO $ Vault.newKey-    registerFinalizer $ Vault.delete key+    registerFinalizer $ put =<< liftIO . Vault.delete key =<< get     return key-readCacheRef  = readCacheKey-writeCacheRef = writeCacheKey+readCacheRef  = readVaultKey+writeCacheRef = writeVaultKey  -- Accumulation values. -- Cache and accumulate a value over several phases. type AccumRef a = Vault.Key a -newAccumRef   :: a -> Compile (AccumRef a)-updateAccum   :: AccumRef a -> (a -> a) -> Run a+newAccumRef    :: a -> Compile (AccumRef a)+readAccumRef   :: AccumRef a -> Run a+updateAccumRef :: AccumRef a -> (a -> a) -> Run a -- strict!  newAccumRef x     = do-    ref   <- liftIO $ Vault.newKey-    writeCacheKey ref x+    ref    <- liftIO $ Vault.newKey+    vault2 <- liftIO . Vault.insert ref x . vault =<< get+    modify $ \cache -> cache { vault = vault2 }     return ref-updateAccum ref f = do-    Just x <- readCacheKey ref +readAccumRef ref  = fromJust <$> readVaultKey ref+updateAccumRef ref f = do+    Just x <- readVaultKey ref      let !y = f x-    writeCacheKey ref y+    writeVaultKey ref y     return y  -- BehaviorRef. -- Cache and accumulate a value over several phases, -- but updates are only visible at the beginning of a new phase.-type BehaviorRef a = (Vault.Key a, Vault.Key a)+-- (accumulator, temporary reference for each phase)+type BehaviorRef a = (AccumRef a, CacheRef a) -newBehaviorRef    :: a -> Compile (BehaviorRef a)-readBehaviorRef   :: BehaviorRef a -> Run a-updateBehaviorRef :: BehaviorRef a -> (a -> a) -> Run () -- Strict!+newBehaviorRefPoll   :: IO a -> Compile (BehaviorRef a)+newBehaviorRefAccum  :: a -> Compile (BehaviorRef a)+readBehaviorRef      :: BehaviorRef a -> Run a+updateBehaviorRef    :: BehaviorRef a -> (a -> a) -> Run () -- strict! -newBehaviorRef x = do-    ref  <- liftIO $ Vault.newKey-    temp <- liftIO $ Vault.newKey-    registerFinalizer $ \vault -> do-        Just x <- Vault.lookup temp vault-        Vault.insert ref x vault-    writeCacheKey ref  x-    writeCacheKey temp x-    return (ref,temp)-readBehaviorRef (ref,temp) = do-    Just x <- readCacheKey ref-    return x-updateBehaviorRef (ref,temp) f = do-    Just x <- readCacheKey temp-    writeCacheKey temp $! f x -- strict!+newBehaviorRef m = do+    temp <- newCacheRef+    registerInitializer $ writeCacheRef temp =<< m+    return (undefined, temp)+newBehaviorRefPoll    = newBehaviorRef . liftIO+newBehaviorRefAccum x = do+    acc  <- newAccumRef x+    (_,temp) <- newBehaviorRef $ readAccumRef acc+    return (acc, temp)+readBehaviorRef   (_, temp)   = fromJust <$> readCacheRef temp+updateBehaviorRef (acc, temp) = void . updateAccumRef acc + {-----------------------------------------------------------------------------     Abstract syntax tree ------------------------------------------------------------------------------}@@ -185,14 +192,14 @@     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 ()+    UpdateAccum    :: AccumRef a    -> Event t (a -> a) -> EventD t a+    UpdateBehavior :: 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 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) @@ -200,6 +207,7 @@     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+    Poll         :: IO a -> BehaviorD t a          -- internal combinators     ReadBehavior :: BehaviorRef a -> BehaviorD t a@@ -219,31 +227,41 @@ {-----------------------------------------------------------------------------     Compilation ------------------------------------------------------------------------------}--- replace every occurence of  accumB  with reading from a cached event-type CompileAccumB = WriterT [Event Shared ()] Compile+-- allocated caches for acummulated and external behaviors,+-- turn them into reads from the cache+type CompileReadBehavior = WriterT [Event Shared ()] Compile -compileAccumB :: Event Accum () -> Compile (Event Shared ())-compileAccumB e1 = do+compileReadBehavior :: Event Accum () -> Compile (Event Shared ())+compileReadBehavior e1 = do         (e,es) <- runWriterT (goE e1)         -- include updates to Behavior as additional events+        let union e1 e2 = (invalidRef, Union e1 e2)         return $ foldr1 union (e:es)-    where-    union e1 e2 = (invalidRef, Union e1 e2)-    +    where         -- 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)-    +    goE :: Event Accum a -> CompileReadBehavior (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 :: Behavior Accum a -> CompileReadBehavior (Behavior Shared a)     goB (ref, Pure x      ) = (ref,) <$> (Pure   <$> return x)     goB (ref, ApplyB bf bx) = (ref,) <$> (ApplyB <$> goB bf <*> goB bx)+    goB (ref, Poll io     ) = (ref,) <$> (ReadBehavior <$> makeRef)+        where+        makeRef = do+            m <- lift . lift $ readRef ref+            case m of+                Just r  -> return r+                Nothing -> do+                    r <- lift $ newBehaviorRefPoll io+                    lift . lift $ writeRef ref r+                    return r     goB (ref, AccumB x e  ) = (ref,) <$> (ReadBehavior <$> makeRef)         where         makeRef = do@@ -251,15 +269,15 @@             case m of                 Just r  -> return r                 Nothing -> do-                    r <- lift $ newBehaviorRef x-                    -- immedately store the cached reference+                    -- create new BehaviorRef and share it+                    r <- lift $ newBehaviorRefAccum x                     lift . lift $ writeRef ref r+                     -- remove  accumB  from the other events                     e <- goE e-                    tell [(invalidRef, WriteBehavior r e)]+                    tell [(invalidRef, UpdateBehavior r e)]                     return r - -- fan out unions into linear paths type EventLinear a = (Channel, Event Linear a) @@ -267,14 +285,14 @@ 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)]+    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 (_  , UpdateBehavior b e) = map2 (UpdateBehavior 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)]          compileAccumE :: a -> [EventLinear (a -> a)] -> Compile [EventLinear a]     compileAccumE x es = do@@ -287,11 +305,11 @@         m <- lift $ readRef ref         case m of             Just cached -> do-                return $ map (\(c,r) -> (c,ReadCache c r)) cached+                return $ map (\(c,r) -> (c, ReadCache c r)) cached             Nothing     -> do                 -- compile input events                 es     <- mes-                -- allocate corresponding cache references+                -- allocate corresponding cache references and share them                 cached <- forM es $ \(c,_) -> do r <- newCacheRef; return (c,r)                 lift $ writeRef ref cached                 -- return events that also write to the cache@@ -302,8 +320,8 @@  -- compile a behavior -- FIXME: take care of sharing, caching-compileBehavior :: Behavior Linear a -> Run a-compileBehavior = goB+compileBehaviorEvaluation :: Behavior Linear a -> Run a+compileBehaviorEvaluation = goB     where     goB :: Behavior Linear a -> Run a     goB (ref, Pure x)            = return x@@ -318,25 +336,25 @@ 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+    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    r e) k = goE e $ \f -> updateAccumRef r f >>= k+    goE (UpdateBehavior r e) _ = goE e $ \x -> updateBehaviorRef r 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 =+    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 =+    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 :: Behavior Linear a -> Run a-    goB = compileBehavior+    goB = compileBehaviorEvaluation  -- compilation function compile :: Event Accum () -> IO ([Path], Cache) compile e = runStore $ runCompile $-    return . map compilePath =<< compileUnion =<< compileAccumB e+    return . map compilePath =<< compileUnion =<< compileReadBehavior e  -- debug :: MonadIO m => String -> m () -- debug = liftIO . putStrLn@@ -391,5 +409,4 @@     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- 

@@ -24,12 +24,24 @@         when (bs1 /= bs2) $ print bs1 >> print bs2         return $ bs1 == bs2 -{-+ testSuite = do-    -- TODO: algebraic laws-    -- larger examples-    quickCheck $ matchesModel decrease-    -}+        -- trivial unit tests+        test add1+        test filtering+        test counter+        test double+        test sharing+        test decrease+        test accumBvsE+        -- TODO:+        --  * algebraic laws+        --  * larger examples+        --  * quickcheck+    where+    test :: (Show b, Eq b) => (forall f. FRP f => Event f Int -> Event f b)+         -> IO ()+    test f = print =<< matchesModel f [1..8::Int]  {-----------------------------------------------------------------------------     Examples