reactive-banana 0.2.0.3 → 0.3.0.0

raw patch · 9 files changed

+448/−187 lines, 9 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• doc/examples/RunPause.hs +77/−0
• doc/examples/SlotMachine.hs +18/−27
• reactive-banana.cabal +6/−4
• src/Reactive/Banana.hs +1/−1
• src/Reactive/Banana/Implementation.hs +189/−88
• src/Reactive/Banana/Model.hs +18/−13
• src/Reactive/Banana/PushIO.hs +76/−48
• src/Reactive/Banana/Tests.hs +5/−6
• src/Reactive/Banana/Vault.hs +58/−0

@@ -0,0 +1,77 @@+{-----------------------------------------------------------------------------+    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+

@@ -3,21 +3,23 @@          Example: Slot machine ------------------------------------------------------------------------------}-import Reactive.Banana as R- 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 <- makeSources-    setupEvents sources+    network <- setupNetwork sources+    run network     eventLoop sources  displayHelpMessage :: IO ()@@ -34,7 +36,7 @@     []  -- Create event sources corresponding to  coin  and  play-makeSources = (,) <$> newEventSource <*> newEventSource+makeSources = (,) <$> newAddHandler <*> newAddHandler  -- Read commands and fire corresponding events  eventLoop :: (EventSource (), EventSource ()) -> IO ()@@ -56,24 +58,13 @@ ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you-data EventSource a = EventSource {-        setHandler :: (a -> IO ()) -> IO (),-        getHandler :: IO (a -> IO ())-        }--newEventSource :: IO (EventSource a)-newEventSource = do-    ref <- newIORef (const $ return ())-    return $-        EventSource { setHandler = writeIORef ref, getHandler = readIORef ref}+type EventSource a = (AddHandler a, a -> IO ())  addHandler :: EventSource a -> AddHandler a-addHandler es k = do-    handler <- getHandler es-    setHandler es (\x -> handler x >> k x)+addHandler = fst -fire :: EventSource a -> (a -> IO ())-fire es x = getHandler es >>= ($ x)+fire :: EventSource a -> a -> IO ()+fire = snd  {-----------------------------------------------------------------------------     Program logic@@ -91,8 +82,8 @@   -- Set up the program logic in terms of events and behaviors.-setupEvents :: (EventSource (), EventSource ()) -> IO ()-setupEvents (escoin,esplay) = prepareEvents $ do+setupNetwork :: (EventSource (), EventSource ()) -> IO EventNetwork+setupNetwork (escoin,esplay) = compile $ do      -- initial random number generator     initialStdGen <- liftIO $ newStdGen@@ -127,10 +118,10 @@                  -- Event: player has enough coins and plays         edoesplay :: Event ()-        edoesplay = () <$ R.filter id  emayplay+        edoesplay = () <$ filterE id  emayplay         -- Event: event that fires when the player doesn't have enough money         edenied   :: Event ()-        edenied   = () <$ R.filter not emayplay+        edenied   = () <$ filterE not emayplay                           -- State: random number generator@@ -150,11 +141,11 @@                  -- Event: it's a win!         ewin :: Event Win-        ewin = fmap fromJust $ R.filter isJust $ fmap checkWin eroll+        ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll         checkWin (z1,z2,z3)-            | z1 == z2 || z2 == z3 || z3 == z1 = Just Double-            | z1 == z2 && z2 == z3             = Just Triple-            | otherwise                        = Nothing+            | length (nub [z1,z2,z3]) == 1 = Just Triple+            | length (nub [z1,z2,z3]) == 2 = Just Double+            | otherwise                    = Nothing       reactimate $ putStrLn . showCredit <$> ecredits

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.2.0.3+Version:             0.3.0.0 Synopsis:            Small but solid library for                      functional reactive programming (FRP). Description:         @@ -47,13 +47,15 @@     extensions:         TypeFamilies, FlexibleContexts,                         FlexibleInstances, EmptyDataDecls,                         GADTs, BangPatterns, TupleSections,-                        Rank2Types, NoMonomorphismRestriction+                        Rank2Types, NoMonomorphismRestriction,+                        DeriveDataTypeable     build-depends:-        base >= 4.2 && < 4.4,+        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,                         Reactive.Banana.Implementation,                         Reactive.Banana.Tests-    other-modules:      Reactive.Banana.PushIO+    other-modules:      Reactive.Banana.PushIO,+                        Reactive.Banana.Vault 

@@ -11,7 +11,7 @@     Event, Behavior     ) where -import Reactive.Banana.Model hiding (run, Event, Behavior)+import Reactive.Banana.Model hiding (interpret, Event, Behavior) import qualified Reactive.Banana.Model as Model import Reactive.Banana.Implementation import qualified Reactive.Banana.Implementation as Implementation

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-----------------------------------------------------------------------------     Reactive Banana     @@ -5,43 +6,55 @@ ------------------------------------------------------------------------------} module Reactive.Banana.Implementation (     -- * Synopsis-    -- | Run event networks and hook them up to existing event-based frameworks.+    -- | Build event networks using existing event-based frameworks+    --   and run them.          -- * Implementation-    PushIO, run,+    PushIO, interpret, -    -- * Using existing event-based frameworks-    -- $Prepare-    Prepare, prepareEvents, reactimate, AddHandler, fromAddHandler, liftIO,+    -- * Building event networks with input and output+    -- $build+    NetworkDescription, compile,+    AddHandler, fromAddHandler, reactimate, liftIO,     +    -- * Running event networks+    EventNetwork, run, pause,+    +    -- * Utilities+    newAddHandler,+         module Data.Dynamic,     ) where -import Reactive.Banana.PushIO as Implementation+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 Data.Dynamic -import Data.List (nub) import Control.Applicative import Control.Monad.RWS++import Data.Dynamic+import Data.List (nub) import Data.IORef+import qualified Data.Map as Map+import Data.Unique  -- debug = putStrLn  {-----------------------------------------------------------------------------     PushIO specific functions ------------------------------------------------------------------------------}-type Flavor = PushIO+type Flavor  = Implementation.PushIO -input :: Typeable a => Channel -> Model.Event PushIO a+input :: Typeable a => Channel -> Model.Event Flavor 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')+compileHandlers graph = do+    -- compile event graph+    let graph' = Implementation.unEvent graph+    (paths,cache) <- Implementation.compile (invalidRef, Reactimate graph')     -- reduce to one path per channel     let paths1 = groupChannelsBy (\p q x -> p x >> q x) paths @@ -63,99 +76,114 @@     where channels = nub . map fst $ xs  {------------------------------------------------------------------------------    Setting up an event network+    NetworkDescription, setting up event networks ------------------------------------------------------------------------------}-{-$Prepare+{-$build      After having read all about 'Event's and 'Behavior's,-    you want to hook things up to an existing event-based framework,+    you want to hook them 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:+    This "Reactive.Banana.Implementation" module allows you to obtain /input/ events+    from external sources+    and it allows you perform /output/ in reaction to events.     +    In constrast, the functions from "Reactive.Banana.Model" allow you +    to express the output events in terms of the input events.+    This expression is called an /event graph/.+    +    An /event network/ is an event graph together with inputs and outputs.+    To build an event network,+    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.+    The network will register its input event handlers and start producing output.++    A typical setup looks like this:+     > main = do->   ... -- other initialization+>   -- initialize your GUI framework+>   window <- newWindow+>   ... >->   -- initialize event network->   prepareEvents $ do->       -- obtain  Event  from functions that register event handlers+>   -- build the event network+>   network <- compile $ do+>       -- input: obtain  Event  from functions that register event handlers >       emouse    <- fromAddHandler (registerMouseEvent window) >       ekeyboard <- fromAddHandler (registerKeyEvent window) >   ->       -- build event network+>       -- express event graph >       let >           behavior1 = accumB ... >           ... >           event15 = union event13 event14 >   ->       -- animate relevant event occurences+>       -- output: animate some 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+>   -- register handlers and start producing outputs+>   run network++    In short, you use 'fromAddHandler' to obtain /input/ events.+    The library uses this to register 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.)+    To animate /output/ events, use the 'reactimate' function.  -} -type AddHandler'  = (Channel, (Universe -> IO ()) -> IO ())+type AddHandler'  = (Channel, AddHandler Universe) type Preparations = ([Model.Event Flavor (IO ())], [AddHandler'])-newtype Prepare a = Prepare { unPrepare :: RWST () Preparations Channel IO a } -instance Monad (Prepare) where+-- | Monad for describing event networks.+-- +-- The 'NetworkDescription' monad is an instance of 'MonadIO',+-- so 'IO' is allowed inside.+-- +-- Note: It is forbidden to smuggle values of types 'Event' or 'Behavior'+-- outside the 'NetworkDescription' monad. This shouldn't be possible by default,+-- but you might get clever and use 'IORef' to circumvent this.+-- Don't do that, it won't work and also has a 99,98% chance of +-- destroying the earth by summoning time-traveling zygohistomorphisms.+newtype NetworkDescription a = Prepare { unPrepare :: RWST () Preparations Channel IO a }++instance Monad (NetworkDescription) where     return  = Prepare . return     m >>= k = Prepare $ unPrepare m >>= unPrepare . k-instance MonadIO Prepare where+instance MonadIO (NetworkDescription) where     liftIO  = Prepare . liftIO+instance Functor (NetworkDescription) where+    fmap f  = Prepare . fmap f . unPrepare+instance Applicative (NetworkDescription) where+    pure    = Prepare . pure+    f <*> a = Prepare $ unPrepare f <*> unPrepare a --- | Animate an output event.--- Executes the 'IO' action whenever the event occurs.-reactimate :: Model.Event PushIO (IO ()) -> Prepare ()+-- | Output.+-- Execute the 'IO' action whenever the event occurs.+reactimate :: Model.Event PushIO (IO ()) -> NetworkDescription () 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 ()+-- | A value of type @AddHandler a@ is just a facility for registering+-- callback functions, also known as event handlers.+-- +-- The type is a bit mysterious, it works like this:+-- +-- > do unregisterMyHandler <- addHandler myHandler+--+-- The argument is an event handler that will be registered.+-- The return value is an action that unregisters this very event handler again.+type AddHandler a = (a -> IO ()) -> IO (IO ()) --- | Obtain an 'Event' from an 'AddHandler'.--- This will register a callback function such that+-- | Input,+-- obtain an 'Event' from an 'AddHandler'.+--+-- When the event network is run,+-- 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 :: Typeable a => AddHandler a -> NetworkDescription (Model.Event PushIO a) fromAddHandler addHandler = Prepare $ do         channel <- newChannel         let addHandler' k = addHandler $ k . toUniverse channel@@ -164,26 +192,99 @@     where     newChannel = do c <- get; put $! c+1; return c +-- | Compile a 'NetworkDescription' into an 'EventNetwork'+-- that you can 'run', 'pause' and so on.+compile :: NetworkDescription () -> IO EventNetwork+compile (Prepare m) = do+    (_,_,(outputs,inputs)) <- runRWST m () 0+    +    let -- union of all  reactimates+        graph = mconcat outputs :: Model.Event Flavor (IO ())+    paths <- compileHandlers graph+    +    let -- register event handlers+        register = fmap sequence_ . sequence . map snd . applyChannels inputs $ paths+    makeEventNetwork register++-- 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]+ {------------------------------------------------------------------------------    Run function for testing+    Running event networks ------------------------------------------------------------------------------}--- | 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 []+-- | Data type that represents a compiled event network.+-- It may be paused or already running.+data EventNetwork = EventNetwork {+    -- | Run 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 (),+    +    -- | Pause an event network.+    -- Immediately stop producing output and+    -- unregister all event handlers for inputs.+    -- Hence, the network stops responding to input events,+    -- but it's state will be preserved.+    --+    -- You can resume the network with 'run'.+    --+    -- Note: You can stop a network even while it is processing events,+    -- i.e. you can use 'pause' as an argument to 'reactimate'.+    -- The network will /not/ stop immediately though, only after+    -- the current event has been processed completely.+    pause :: IO ()+    } deriving (Typeable) -    href <- newIORef []-    let addHandler k = modifyIORef href (++[k])+-- Make an event network from a function that registers all event handlers+makeEventNetwork :: IO (IO ()) -> IO EventNetwork+makeEventNetwork register = do+    let nop = return ()+    unregister <- newIORef nop+    let+        run   = register >>= writeIORef unregister+        pause = readIORef unregister >>= id >> writeIORef unregister nop+    return $ EventNetwork run pause -    prepareEvents $ do-        e <- fromAddHandler addHandler-        reactimate $ fmap (\b -> modifyIORef oref (++[b])) (f e) -    handler <- (\ks x -> mapM ($ x) ks) <$> readIORef href+{-----------------------------------------------------------------------------+    Interpreter for testing+------------------------------------------------------------------------------}+-- | Simple way to run an event graph. Very useful for testing.+interpret :: Typeable a+    => (Model.Event PushIO a -> Model.Event PushIO b) -> [a] -> IO [[b]]+interpret f xs = do+    output                    <- newIORef []+    (addHandler, runHandlers) <- newAddHandler+    network                   <- compile $ do+        e <- fromAddHandler addHandler+        reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) -    forM xs $ \x -> do-        handler x-        bs <- readIORef oref-        writeIORef oref []+    run network+    bs <- forM xs $ \x -> do+        runHandlers x+        bs <- readIORef output+        writeIORef output []         return bs+    return bs+++{-----------------------------------------------------------------------------+    Utilities+------------------------------------------------------------------------------}+-- | 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+    let addHandler k = do+            key <- newUnique+            modifyIORef handlers $ Map.insert key k+            return $ modifyIORef handlers $ Map.delete key+        runHandlers x =+            mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers+    return (addHandler, runHandlers)+

@@ -18,7 +18,7 @@          -- * Model implementation     Model,-    Time, interpret, run,+    Time, interpretTime, interpret,     ) where  import Control.Applicative@@ -89,11 +89,11 @@     -- | 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+    -- > filterE p es = [(time,a) | (time,a) <- es, p a]+    filterE   :: (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'.+    -- It's a slight generalization of 'filterE'.     filterApply :: Behavior f (a -> Bool) -> Event f a -> Event f a          @@ -119,21 +119,26 @@     -- For example, think     --     -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))]-    -- >    = behavior "x" [(time1,"yx"),(time2,"zyx")]+    -- >    = stepper "x" [(time1,"xy"),(time2,"xyz")]     --      -- 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.+    -- Example:+    --+    -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))]+    -- >    = [(time1,"xy"),(time2,"xyz")]+    --     -- 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)    +    filterE p = filterApply (pure p)+    filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp)              -- implementation accumulation     accumB  acc = stepper acc . accumE acc@@ -229,14 +234,14 @@  -- | 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 (:[])+interpret :: (Event Model a -> Event Model b) -> [a] -> [[b]]+interpret 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+interpretTime :: (Event Model a -> Event Model b) -> [(Time,a)] -> [(Time,b)]+interpretTime f xs =+    concat . zipWith tag times . interpret f . map snd $ xs     where     times = map fst xs     tag t xs = map (\x -> (t,x)) xs@@ -250,7 +255,7 @@     bcounter     = accumB 10 $ (subtract 1) <$ ecandecrease     ecandecrease = whenE ((>0) <$> bcounter) edec -testModel = run example $ replicate 15 ()+testModel = interpret example $ replicate 15 () -- > testModel -- [[10],[9],[8],[7],[6],[5],[4],[3],[2],[1],[],[],[],[],[]] 

@@ -7,12 +7,14 @@      TupleSections, BangPatterns #-} module Reactive.Banana.PushIO where -import Reactive.Banana.Model hiding (Event, Behavior, run)+import Reactive.Banana.Model hiding (Event, Behavior, interpret) import qualified Reactive.Banana.Model as Model +import Reactive.Banana.Vault (Vault)+import qualified Reactive.Banana.Vault as Vault++ import Control.Applicative-import qualified Data.List-import Prelude hiding (filter) import Data.Monoid  import Control.Monad.Trans.Identity@@ -53,85 +55,107 @@ invalidRef = error "Store: invalidRef. This is an internal bug."  {------------------------------------------------------------------------------    Cache+    Cache, generalities ------------------------------------------------------------------------------}--- a cache stores values of different types--- This is done with IORefs and a list of finalizerss-type Cache = [IO ()]--emptyCache = []+-- A cache stores values of different types+-- and finalizers to change them.+data Cache = Cache { vault :: Vault, finalizers :: [Finalizer] }+type Finalizer = Vault -> IO Vault --- FIXME: add initializers to the Cache, so we can use it--- like a data store!+emptyCache = Cache Vault.empty []  -- monad to build the network in type Compile = StateT Cache Store -- monad to run the network in-type Run     = IdentityT IO+type Run     = StateT Cache IO  runCompile :: Compile a -> Store (a, Cache)-runCompile m = runStateT m []+runCompile m = runStateT m $ Cache { vault = Vault.empty, finalizers = [] } -registerFinalizer :: IO () -> Compile ()-registerFinalizer m = modify $ (++[m])+registerFinalizer :: Finalizer -> Compile ()+registerFinalizer m = modify $+    \cache -> cache { finalizers = finalizers cache ++ [m] } +runFinalizers :: [Finalizer] -> Vault -> IO Vault+runFinalizers = foldr (>=>) return+ 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+    -- 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'}) --- a simple value to be cached. Lasts one phase.-type CacheRef a = IORef (Maybe a)+-- 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) +{-----------------------------------------------------------------------------+    Cache, particular reference types+------------------------------------------------------------------------------}+-- CacheRef+-- A simple value to be cached. Lasts one phase. Useful for sharing.+type CacheRef a = Vault.Key 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+newCacheRef      = do+    key <- liftIO $ Vault.newKey+    registerFinalizer $ Vault.delete key+    return key+readCacheRef  = readCacheKey+writeCacheRef = writeCacheKey --- accumulation values--- cache a value over several phases-type AccumRef a = IORef a+-- 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       = liftIO . newIORef+newAccumRef x     = do+    ref   <- liftIO $ Vault.newKey+    writeCacheKey ref x+    return ref updateAccum ref f = do-    x <- liftIO $ readIORef ref+    Just x <- readCacheKey ref      let !y = f x-    liftIO $ writeIORef ref y+    writeCacheKey ref y     return y --- behaviors--- Cache a value over several phases,+-- BehaviorRef.+-- Cache and accumulate a value over several phases, -- but updates are only visible at the beginning of a new phase.-type BehaviorRef a = (IORef a, IORef a)+type BehaviorRef a = (Vault.Key a, Vault.Key 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+    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) = liftIO $ readIORef ref--updateBehaviorRef (ref,temp) f = liftIO $ do-    x <- readIORef temp-    writeIORef temp $! f x -- strict!+readBehaviorRef (ref,temp) = do+    Just x <- readCacheKey ref+    return x+updateBehaviorRef (ref,temp) f = do+    Just x <- readCacheKey temp+    writeCacheKey temp $! f x -- strict!  {-----------------------------------------------------------------------------     Abstract syntax tree@@ -320,6 +344,10 @@ {-----------------------------------------------------------------------------     Class instances ------------------------------------------------------------------------------}+-- | The type index 'PushIO' represents the efficient push-driven implementation+-- described here.+-- It implements the same 'FRP' interface as the model implementation+-- represented by 'Model'. data PushIO  -- type Behavior = Model.Behavior PushIO@@ -359,7 +387,7 @@ instance FRP PushIO where     never = event $ Never     union (Event e1) (Event e2) = event $ Union e1 e2-    filter p (Event e) = event $ Filter p e+    filterE 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

@@ -6,7 +6,6 @@ {-# LANGUAGE Rank2Types, NoMonomorphismRestriction #-} module Reactive.Banana.Tests where -import Prelude hiding (filter) import Control.Monad (when)  import Reactive.Banana.Model as Model@@ -20,8 +19,8 @@ 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+        let bs1 = Model.interpret f xs+        bs2 <- Impl.interpret f xs         when (bs1 /= bs2) $ print bs1 >> print bs2         return $ bs1 == bs2 @@ -35,15 +34,15 @@ {-----------------------------------------------------------------------------     Examples ------------------------------------------------------------------------------}-test f = Impl.run f [1..8::Int]+test f = Impl.interpret f [1..8::Int]  add1      = fmap (+1)-filtering = filter (>= 3) . fmap (subtract 1)+filtering = filterE (>= 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+    where e1 = filterE (< 3) e  type Dummy = Int 

@@ -0,0 +1,58 @@+{-----------------------------------------------------------------------------+    Reactive Banana++    Helper Module: A typed, inhomogeneous storage.+    Uses  IORefs  to read and write.+------------------------------------------------------------------------------}+module Reactive.Banana.Vault (+    Vault, Key,+    empty, newKey, lookup, insert, delete,+    ) where++import Prelude hiding (lookup)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.IORef+import Data.Unique++-- | An inhomogeneous, type safe storage.+type Vault = Map Unique Item+-- Values are stored in closures that write to a temporary IORef+-- This way, we can "circumvent" the type system.+type Item  = IO ()++-- Key for the vault+data Key a   = Key Unique (Item' a)+-- Keeps track of the temporary IORef for reading and writing+type Item' a = IORef (Maybe a)++-- | The empty vault.+empty :: Vault+empty = Map.empty++-- | Create a new key for use with a vault.+newKey   :: IO (Key a)+newKey = do+    k   <- newUnique+    ref <- newIORef Nothing+    return $ Key k ref++-- | Lookup the value of a key in the vault.+lookup :: Key a -> Vault -> IO (Maybe a)+lookup (Key k ref) vault = case Map.lookup k vault of+    Nothing   -> return Nothing+    Just item -> do+        item                    -- write into IORef+        mx <- readIORef ref     -- read the value+        writeIORef ref Nothing  -- clear IORef+        return mx++-- | Insert a value for a given key. Overwrites any previous value.+insert :: Key a -> a -> Vault -> IO Vault+insert (Key k ref) x vault = return $+    Map.insert k (writeIORef ref $ Just x) vault++-- | Delete a key from the vault.+delete :: Key a -> Vault -> IO Vault+delete (Key k ref) vault = return $ Map.delete k vault+