reactive-banana 0.4.2.0 → 0.4.3.0

raw patch · 3 files changed

+74/−40 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• reactive-banana.cabal +1/−1
• src/Reactive/Banana/Implementation.hs +43/−20
• src/Reactive/Banana/PushIO.hs +30/−19

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.4.2.0+Version:             0.4.3.0 Synopsis:            Small but solid library for                      functional reactive programming (FRP). Description:         

@@ -24,10 +24,11 @@     -- $utilities     newAddHandler,     -    module Data.Dynamic,+    module Data.Dynamic, -- remove this when bumping to 0.5     ) where  import Control.Applicative+import Control.Arrow (second) import Control.Concurrent import Control.Monad import Control.Monad.Fix       (MonadFix(..))@@ -45,8 +46,6 @@ import qualified Reactive.Banana.PushIO as Implementation import qualified Reactive.Banana.Model as Model --- debug = putStrLn- {-----------------------------------------------------------------------------     PushIO specific functions ------------------------------------------------------------------------------}@@ -62,28 +61,36 @@ 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+    (paths1,cache) <- Implementation.compile (invalidRef, Reactimate graph')      -- prepare threading the cache as state     rcache <- newEmptyMVar     putMVar rcache cache-    let run m = do-            -- takeMVar  makes sure that network runs are sequential-            -- In particular, the network will deadlock-            -- if you try to call an event handler during a  reactimate .+    let -- run a single path+        run m = do+            -- takeMVar  makes sure that event graph updates are sequential.             cache <- takeMVar rcache-            (_,cache') <- runRun m cache+            (reactimates,cache') <- runRun m cache             putMVar rcache cache'-        paths2 = map (\(i,p) -> (i, run . p)) $ paths1+            -- However, the corresponding IO actions are run afterwards,+            -- and under certain circumstances, they can *interleave*.+            reactimates+         +        appendReactimates+            :: [Universe -> Run (IO ())]+            -> (Universe -> Run (IO ()))+        appendReactimates ps x = do+            reactimates <- sequence $ map ($ x) ps+            return $ sequence_ reactimates+            +        paths2 = map (second $ (run .) . appendReactimates) $ groupByChannel 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]+groupByChannel :: [(Channel, a)] -> [(Channel, [a])]+groupByChannel xs = [(i, [x | (j,x) <- xs, i == j]) | i <- channels]     where channels = nub . map fst $ xs  {-----------------------------------------------------------------------------@@ -177,8 +184,25 @@ instance MonadFix (NetworkDescription) where     mfix f  = Prepare $ mfix (unPrepare . f) --- | Output.--- Execute the 'IO' action whenever the event occurs.+{- | Output.+    Execute the 'IO' action whenever the event occurs.+    +    +    Note: If two events occur very close to each other,+    there is no guarantee that the @reactimate@s for one +    event will have finished before the ones for the next event start executing.+    This does /not/ affect the values of events and behaviors,+    it only means that the @reactimate@ for different events may interleave.+    Fortuantely, this is a very rare occurrence, and only happens if+    +    * you call an event handler from inside 'reactimate',+    +    * or you use concurrency.+    +    In these cases, the @reactimate@s follow the control flow+    of your event-based framework.++-} reactimate :: Model.Event PushIO (IO ()) -> NetworkDescription () reactimate e = Prepare $ tell ([e], [], []) @@ -292,8 +316,7 @@     Simple use ------------------------------------------------------------------------------} -- | 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 :: (Model.Event PushIO a -> Model.Event PushIO b) -> [a] -> IO [[b]] interpret f xs = do     output                    <- newIORef []     (addHandler, runHandlers) <- newAddHandler@@ -310,8 +333,8 @@     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)+interpretAsHandler+    :: (Model.Event PushIO a -> Model.Event PushIO b)     -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = \handlerB -> do     network <- compile $ do

@@ -15,18 +15,20 @@   import Control.Applicative+import Control.Arrow (second) import Control.Monad import Control.Monad.IO.Class       (liftIO) import Control.Monad.Trans.Class    (lift) import Control.Monad.Trans.Identity import Control.Monad.Trans.State import Control.Monad.Trans.Writer-import Data.Dynamic-import Data.IORef import Data.Maybe import Data.Monoid import System.IO.Unsafe +import System.IO+-- debug s = hPutStrLn stderr s+ {-----------------------------------------------------------------------------     Observable sharing     @@ -36,22 +38,22 @@     In this case, the environment is passed around by the  Store  monad. ------------------------------------------------------------------------------} -- store monad-type Store = IO+type Store = StateT Vault IO -- references to observe sharing-type Ref a = IORef (Maybe a)+type Ref a = Vault.Key a  runStore :: Store a -> IO a-runStore = id+runStore m = evalStateT m Vault.empty  -- create a new reference.-newRef   :: Store (Ref a)+newRef   :: IO (Ref a) -- read a reference. Only possible in the  Store  monad. readRef  :: Ref a -> Store (Maybe a) writeRef :: Ref a -> a -> Store () -newRef   = newIORef Nothing-readRef  = readIORef-writeRef ref = writeIORef ref . Just+newRef         = Vault.newKey+readRef ref    = Vault.lookup ref <$> get+writeRef ref x = modify $ Vault.insert ref x  -- invalid reference that may not store values invalidRef = error "Store: invalidRef. This is an internal bug."@@ -136,13 +138,17 @@     vault2 <- Vault.insert ref x . vault <$> get     modify $ \cache -> cache { vault = vault2 }     return ref-readAccumRef ref  = fromJust <$> readVaultKey ref+readAccumRef ref  =+    fromJustError "Reactive.Banana.PushIO.readAccumRef: internal error"+    <$> readVaultKey ref updateAccumRef ref f = do     Just x <- readVaultKey ref      let !y = f x     writeVaultKey ref y     return y +fromJustError e = maybe (error e) id+ -- BehaviorRef. -- Cache and accumulate a value over several phases, -- but updates are only visible at the beginning of a new phase.@@ -163,7 +169,9 @@     acc  <- newAccumRef x     (_,temp) <- newBehaviorRef $ readAccumRef acc     return (acc, temp)-readBehaviorRef   (_, temp)   = fromJust <$> readCacheRef temp+readBehaviorRef   (_, temp)   =+    fromJustError "Reactive.Banana.PushIO.readBehaviorRef: internal error"+    <$> readCacheRef temp updateBehaviorRef (acc, temp) = void . updateAccumRef acc  @@ -322,7 +330,6 @@                 -- return events that also write to the cache                 return $ zipWith (second . (WriteCache . snd)) cached es -second f (a,b) = (a, f b) map2 = map . second  -- compile a behavior@@ -337,23 +344,27 @@   -- compile path into an IO action-type Path = (Channel, Universe -> Run ())+type Path = (Channel, Universe -> Run (IO ()))+-- (input_channel, \input_value ->+--      do change event_graph_state; return (reactimates_to_be_run) )  compilePath :: Event Linear () -> Path-compilePath e = goE e return+compilePath e = goE e (const $ return nop)     where-    goE :: Event Linear a -> (a -> Run ()) -> (Channel, Universe -> Run ())-    goE (Filter p e)         k = goE e $ \x -> when (p x) (k x)+    goE :: Event Linear a -> (a -> Run (IO ())) -> Path+    goE (Filter p e)         k = goE e $ \x -> if p x then k x else return nop     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+    goE (UpdateBehavior r e) _ = goE e $ \x -> do updateBehaviorRef r x; return nop         -- note: no  k  here because writing behaviors is the end of a path-    goE (Reactimate e)       _ = goE e $ \x -> liftIO x+    goE (Reactimate e)       _ = goE e $ \x -> return x     goE (ReadCache c ref)    k =-            (c, \_ -> readCacheRef ref >>= maybe (return ()) k)+            (c, \_ -> readCacheRef ref >>= maybe (return nop) k)     goE (WriteCache ref e)   k = goE e $ \x -> writeCacheRef ref x >> k x     goE (Input channel key)  k =             (channel, maybe (error "wrong channel") k . fromUniverse key)+    +    nop = return () :: IO ()          goB :: Behavior Linear a -> Run a     goB = compileBehaviorEvaluation