reactive-banana 0.8.1.2 → 0.9.0.0

raw patch · 28 files changed

+1254/−850 lines, 28 filesdep +pqueuedep ~psqueuesPVP ok

version bump matches the API change (PVP)

Dependencies added: pqueue

Dependency ranges changed: psqueues

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• doc/examples/Bug.hs +24/−0
• reactive-banana.cabal +12/−23
• src/Control/Monad/Trans/RWSIO.hs +84/−0
• src/Control/Monad/Trans/ReaderWriterIO.hs +94/−0
• src/Reactive/Banana/Combinators.hs +11/−4
• src/Reactive/Banana/Frameworks.hs +39/−2
• src/Reactive/Banana/Internal/Combinators.hs +37/−40
• src/Reactive/Banana/Model.hs +3/−3
• src/Reactive/Banana/Prim.hs +79/−2
• src/Reactive/Banana/Prim/Cached.hs +17/−23
• src/Reactive/Banana/Prim/Combinators.hs +12/−61
• src/Reactive/Banana/Prim/Compile.hs +42/−14
• src/Reactive/Banana/Prim/Dated.hs +0/−106
• src/Reactive/Banana/Prim/Dependencies.hs +82/−147
• src/Reactive/Banana/Prim/Evaluation.hs +99/−54
• src/Reactive/Banana/Prim/Graph.hs +77/−0
• src/Reactive/Banana/Prim/IO.hs +23/−20
• src/Reactive/Banana/Prim/Order.hs +0/−90
• src/Reactive/Banana/Prim/OrderedBag.hs +35/−0
• src/Reactive/Banana/Prim/Plumbing.hs +189/−103
• src/Reactive/Banana/Prim/Test.hs +2/−0
• src/Reactive/Banana/Prim/Types.hs +163/−143
• src/Reactive/Banana/Prim/Util.hs +64/−0
• src/Reactive/Banana/Switch.hs +7/−1
• src/Reactive/Banana/Test.hs +47/−13
• src/Reactive/Banana/Test/Plumbing.hs +1/−1
• src/Reactive/Banana/Types.hs +1/−0

@@ -1,6 +1,16 @@ Changelog for the `reactive-banana` package ------------------------------------------- +**version 0.9.0.0**++* Implement garbage collection for dynamically switched events.+* Fix issue [#79][] where recursive declarations would sometimes result in dropped events.+* Limit value recursion in the `Moment` monad slightly.+* Change `initial` and `valueB` to behave subtly different when it comes to value recursion in the `Moment` monad.+* Add `Functor`, `Applicative` and `Monad` instances for the `FrameworksMoment` type.+* Depend on the [pqueues][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC.+  [#79]: https://github.com/HeinrichApfelmus/reactive-banana/issues/79+ **version 0.8.1.2**  * Depend on the [psqueues][] package instead of the [pqueue][] package for the priority queue.

@@ -0,0 +1,24 @@+{-# LANGUAGE RecursiveDo #-}+module RBBug where++import Reactive.Banana+import Reactive.Banana.Frameworks++data State = State { stateCounter :: Int }++test :: Int -> IO ()+test n = do+    compile $ network n+    return ()++network :: Frameworks t => Int -> Moment t ()+network 1 = mdo+    let state = pure (State 0) -- switchB (pure (State 0)) never+    positivityChanges <- changes isPositive+    reactimate' (fmap (fmap print) positivityChanges)+    let isPositive = fmap ((>= 0) . stateCounter) state+    return ()+network 2 = mdo+    let b = stepper (State 0) e+    e <- execute $ (\a -> FrameworksMoment $ return a) <$> (b <@ never)+    return ()

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.8.1.2+Version:             0.9.0.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).@@ -13,14 +13,10 @@     .     No semantic bugs expected.     .-    Significant API changes are likely in future versions,-    though the main interface is beginning to stabilize.+    Significant API changes are planned for version 1.0.     .     The library features an efficient, push-driven implementation     and has seen some optimization work.-    However, the inner loop still has a rather large constant factor overhead.-    Moreover, there is currently /no/ garbage collection for events that are-    created dynamically with @Reactive.Banana.Switch@.  Homepage:            http://wiki.haskell.org/Reactive-banana License:             BSD3@@ -50,24 +46,14 @@  Library     hs-source-dirs:     src-    -    extensions:         RecursiveDo,-                        Rank2Types, ScopedTypeVariables,-                        ExistentialQuantification,-                        TypeSynonymInstances, FlexibleInstances,-                        NoMonomorphismRestriction-    +     build-depends:      base >= 4.2 && < 5,                         containers >= 0.5 && < 0.6,                         transformers >= 0.2 && < 0.5,-                        vault == 0.3.*--    extensions:         EmptyDataDecls,-                        BangPatterns--    build-depends:      unordered-containers >= 0.2.1.0 && < 0.3,+                        vault == 0.3.*,+                        unordered-containers >= 0.2.1.0 && < 0.3,                         hashable >= 1.1 && < 1.3,-                        psqueues >= 0.2 && < 0.3+                        pqueue >= 1.0 && < 1.4  --      CPP-options:    -DUseExtensions         @@ -83,18 +69,21 @@                         Reactive.Banana.Switch          other-modules:+                        Control.Monad.Trans.ReaderWriterIO,+                        Control.Monad.Trans.RWSIO,                         Reactive.Banana.Internal.Combinators,                         Reactive.Banana.Internal.Phantom,                         Reactive.Banana.Prim.Combinators,                         Reactive.Banana.Prim.Compile,-                        Reactive.Banana.Prim.Dated,                         Reactive.Banana.Prim.Dependencies,                         Reactive.Banana.Prim.Evaluation,+                        Reactive.Banana.Prim.Graph,                         Reactive.Banana.Prim.IO,-                        Reactive.Banana.Prim.Order,+                        Reactive.Banana.Prim.OrderedBag,                         Reactive.Banana.Prim.Plumbing,                         Reactive.Banana.Prim.Test,                         Reactive.Banana.Prim.Types,+                        Reactive.Banana.Prim.Util,                         Reactive.Banana.Types  Test-Suite tests@@ -106,4 +95,4 @@                         test-framework >= 0.6 && < 0.9,                         test-framework-hunit >= 0.2 && < 0.4,                         reactive-banana, vault, containers, transformers,-                        unordered-containers, hashable, psqueues+                        unordered-containers, hashable, psqueues, pqueue

@@ -0,0 +1,84 @@+module Control.Monad.Trans.RWSIO (+    -- * Synopsis+    -- | An implementation of the reader/writer/state monad transformer+    -- using an 'IORef'.+    +    -- * Documentation+    RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put,+    ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.IORef+import Data.Monoid++{-----------------------------------------------------------------------------+    Type and class instances+------------------------------------------------------------------------------}+data Tuple r w s = Tuple !r !(IORef w) !(IORef s)++newtype RWSIOT r w s m a = R { run :: Tuple r w s -> m a }++instance Functor m => Functor (RWSIOT r w s m) where fmap = fmapR++instance Applicative m => Applicative (RWSIOT r w s m) where+    pure  = pureR+    (<*>) = apR+    +instance Monad m => Monad (RWSIOT r w s m) where+    return = returnR+    (>>=)  = bindR++instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR+instance MonadIO m => MonadIO (RWSIOT r w s m)   where liftIO = liftIOR+instance MonadTrans (RWSIOT r w s)               where lift = liftR++{-----------------------------------------------------------------------------+    Functions+------------------------------------------------------------------------------}+liftIOR m = R $ \_ -> liftIO m+liftR   m = R $ \_ -> m+fmapR f m = R $ \x -> fmap f (run m x)+returnR a = R $ \_ -> return a+bindR m k = R $ \x -> run m x >>= \a -> run (k a) x+mfixR f   = R $ \x -> mfix (\a -> run (f a) x)+pureR a   = R $ \_ -> pure a+apR f a   = R $ \x -> run f x <*> run a x++rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a+rwsT f = do+    r <- ask+    s <- get+    (a,s,w) <- liftIOR $ f r s+    put  s+    tell w+    return a++runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w))+runRWSIOT m r s = do+    w' <- liftIO $ newIORef mempty+    s' <- liftIO $ newIORef s +    a  <- run m (Tuple r w' s')+    s  <- liftIO $ readIORef s'+    w  <- liftIO $ readIORef w'+    return (a,s,w)++tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m ()+tell w = R $ \(Tuple _ w' _) -> liftIO $ modifyIORef w' (`mappend` w)++ask :: Monad m => RWSIOT r w s m r+ask = R $ \(Tuple r _ _) -> return r++get :: MonadIO m => RWSIOT r w s m s+get = R $ \(Tuple _ _ s') -> liftIO $ readIORef s'++put :: MonadIO m => s -> RWSIOT r w s m ()+put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s++test :: RWSIOT String String () IO ()+test = do+    c <- ask+    tell c

@@ -0,0 +1,94 @@+{-# LANGUAGE TypeFamilies #-}+module Control.Monad.Trans.ReaderWriterIO (+    -- * Synopsis+    -- | An implementation of the reader/writer monad transformer+    -- using an 'IORef' for the writer.+    +    -- * Documentation+    ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local,+    ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.IORef+import Data.Monoid++{-----------------------------------------------------------------------------+    Type and class instances+------------------------------------------------------------------------------}+newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a }++instance Functor m => Functor (ReaderWriterIOT r w m)   where fmap = fmapR++instance Applicative m => Applicative (ReaderWriterIOT r w m) where+    pure  = pureR+    (<*>) = apR+    +instance Monad m => Monad (ReaderWriterIOT r w m) where+    return = returnR+    (>>=)  = bindR++instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR+instance MonadIO m => MonadIO (ReaderWriterIOT r w m)   where liftIO = liftIOR+instance MonadTrans (ReaderWriterIOT r w)               where lift = liftR++instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where+    mempty          = return ()+    mx `mappend` my = mx >> my++{-----------------------------------------------------------------------------+    Functions+------------------------------------------------------------------------------}+liftIOR m = ReaderWriterIOT $ \x y -> liftIO m++liftR m = ReaderWriterIOT $ \x y -> m++fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y)++returnR a = ReaderWriterIOT $ \_ _ -> return a++bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y++mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y)++pureR a = ReaderWriterIOT $ \_ _ -> pure a++apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y++readerWriterIOT :: (MonadIO m, Monoid w) =>+    (r -> IO (a, w)) -> ReaderWriterIOT r w m a+readerWriterIOT f = do+    r <- ask+    (a,w) <- liftIOR $ f r+    tell w+    return a++runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w)+runReaderWriterIOT m r = do+    ref <- liftIO $ newIORef mempty+    a   <- run m r ref+    w   <- liftIO $ readIORef ref+    return (a,w)++tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m ()+tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w)++listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w)+listen m = ReaderWriterIOT $ \r ref -> do+    a <- run m r ref+    w <- liftIO $ readIORef ref+    return (a,w)++local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a+local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref++ask :: Monad m => ReaderWriterIOT r w m r+ask = ReaderWriterIOT $ \r _ -> return r++test :: ReaderWriterIOT String String IO ()+test = do+    c <- ask+    tell c

@@ -76,7 +76,10 @@ -- Useful for testing. interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] interpret f xs =-    map toList <$> Prim.interpret (return . unE . f . E) (map Just xs)+    map toList <$> Prim.interpret (return . unE . f . E) (map wrap xs)+    where+    wrap [] = Nothing+    wrap xs = Just xs  toList :: Maybe [a] -> [a] toList Nothing   = []@@ -174,8 +177,11 @@      mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a     mapAccumE acc =-        Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd)+        Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE lift +    lift f (_,acc) = acc `seq` f acc++ -- strict version of scanl scanl' :: (a -> b -> a) -> a -> [b] -> [a] scanl' f x ys = x : case ys of@@ -312,5 +318,6 @@ -- | Efficient combination of 'accumE' and 'accumB'. mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e))-    where e = accumE (undefined,acc) ((. snd) <$> ef)-+    where+    e = accumE (undefined,acc) (lift <$> ef)+    lift f (_,acc) = acc `seq` f acc

@@ -16,7 +16,10 @@     compile, Frameworks,     module Control.Event.Handler,     fromAddHandler, fromChanges, fromPoll,-    reactimate, Future, reactimate', initial, changes, imposeChanges,+    reactimate, Future, reactimate', initial,+    changes,+    -- $changes+    imposeChanges,     FrameworksMoment(..), execute, liftIOLater,     -- $liftIO     module Control.Monad.IO.Class,@@ -190,8 +193,13 @@  -- | Output, -- observe the initial value contained in a 'Behavior'.+--+-- NOTE: To allow for more recursion, the value is returned /lazily/+-- and not available for pattern matching immediately.+--+-- If that doesn't work for you, please use 'valueB' instead. initial :: Behavior t a -> Moment t a-initial = M . Prim.initialB . unB+initial = M . Prim.initialBLater . unB  -- | Output, -- observe when a 'Behavior' changes.@@ -213,6 +221,26 @@ changes :: Frameworks t => Behavior t a -> Moment t (Event t (Future a)) changes = return . fmap F . singletonsE . Prim.changesB . unB +{- $changes++Note: If you need a variant of the 'changes' function that does /not/+have the additional 'Future' type, then the following code snippet+may be useful:++> plainChanges :: Frameworks t => Behavior t a -> Moment t (Event t a)+> plainChanges b = do+>     (e, handle) <- newEvent+>     eb <- changes b+>     reactimate' $ (fmap handle) <$> eb+>     return e++However, this approach is not recommended, because the result 'Event'+will occur /slightly/ later than the event returned by 'changes'.+In fact, there is no guarantee whatsoever about what /slightly/ means+in this context. Still, it is useful in some cases.++-}+ -- | Impose a different sampling event on a 'Behavior'. -- -- The 'Behavior' will vary continuously as before, but the event returned@@ -227,6 +255,15 @@ newtype FrameworksMoment a     = FrameworksMoment     { runFrameworksMoment :: forall t. Frameworks t => Moment t a }++instance Functor FrameworksMoment where+    fmap f (FrameworksMoment x) = FrameworksMoment (fmap f x)+instance Applicative FrameworksMoment where+    pure x = FrameworksMoment (pure x)+    (FrameworksMoment f) <*> (FrameworksMoment x) = FrameworksMoment (f <*> x)+instance Monad FrameworksMoment where+    return x = FrameworksMoment (return x)+    (FrameworksMoment m) >>= g = FrameworksMoment (m >>= runFrameworksMoment . g)  unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a unFM = runFrameworksMoment

@@ -14,36 +14,23 @@ import           Data.Functor import           Data.Functor.Identity import           Data.IORef-import qualified Data.Vault.Lazy             as Lazy import qualified Reactive.Banana.Prim        as Prim-import qualified Reactive.Banana.Prim.Cached as Prim-import           Reactive.Banana.Prim.Cached         hiding (runCached)+import           Reactive.Banana.Prim.Cached  type Build   = Prim.Build-type Latch   = Prim.Latch-type Pulse   = Prim.Pulse+type Latch a = Prim.Latch a+type Pulse a = Prim.Pulse a type Future  = Prim.Future  {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}-type Behavior a = Cached Moment' (Latch a, Pulse ())-type Event a    = Cached Moment' (Pulse a)--type MomentT m  = ReaderT EventNetwork (Prim.BuildT m)-type Moment     = MomentT IO-type Moment'    = MomentT Identity--instance (Monad m, MonadFix m, HasCache m)-    => HasCache (ReaderT EventNetwork m) where-        retrieve key = lift $ retrieve key-        write key a  = lift $ write key a--liftBuild :: Monad m => Build a -> MomentT m a-liftBuild = lift . Prim.liftBuild+type Behavior a = Cached Moment (Latch a, Pulse ())+type Event a    = Cached Moment (Pulse a)+type Moment     = ReaderT EventNetwork Prim.Build -runCached :: Monad m => Cached Moment' a -> MomentT m a-runCached = mapReaderT Prim.liftBuild . Prim.runCached+liftBuild :: Build a -> Moment a+liftBuild = lift  {-----------------------------------------------------------------------------     Interpretation@@ -94,16 +81,18 @@  fromAddHandler :: AddHandler a -> Moment (Event a) fromAddHandler addHandler = do-    key       <- liftIO $ Lazy.newKey-    (p, fire) <- liftBuild $ Prim.newInput key+    (p, fire) <- liftBuild $ Prim.newInput     network   <- ask     liftIO $ register addHandler $ runStep network . fire     return $ Prim.fromPure p  addReactimate :: Event (Future (IO ())) -> Moment () addReactimate e = do-    p <- runCached e-    liftBuild $ Prim.addHandler p id+    network   <- ask+    liftBuild $ Prim.buildLater $ do+        -- Run cached computation later to allow more recursion with `Moment`+        p <- runReaderT (runCached e) network+        Prim.addHandler p id  fromPoll :: IO a -> Moment (Behavior a) fromPoll poll = do@@ -154,38 +143,46 @@ {-----------------------------------------------------------------------------     Combinators - dynamic event switching ------------------------------------------------------------------------------}-initialB :: Behavior a -> Moment a-initialB b = do+liftBuildFun :: (Build a -> Build b) -> Moment a -> Moment b+liftBuildFun f m = do+    r <- ask+    liftBuild $ f $ runReaderT m r++valueB :: Behavior a -> Moment a+valueB b = do     ~(l,_) <- runCached b     liftBuild $ Prim.readLatch l +initialBLater :: Behavior a -> Moment a+initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB+ trimE :: Event a -> Moment (Moment (Event a)) trimE e = do-    p <- runCached e                   -- add pulse to network-    -- NOTE: if the pulse is not connected to an input node,-    -- it will be garbage collected right away.-    -- TODO: Do we need to check for this?-    return $ return $ fromPure p       -- remember it henceforth+    -- make sure that the event is added to the network eventually+    liftBuildFun Prim.buildLater $ void $ runCached e+    return $ return $ e  trimB :: Behavior a -> Moment (Moment (Behavior a)) trimB b = do-    ~(l,p) <- runCached b               -- add behavior to network-    return $ return $ fromPure (l,p)    -- remember it henceforth+    -- make sure that the behavior is added to the network eventually+    liftBuildFun Prim.buildLater $ void $ runCached b+    return $ return $ b -executeP :: Monad m => Pulse (Moment a) -> MomentT m (Pulse a)+executeP :: Pulse (Moment a) -> Moment (Pulse a) executeP p1 = do-    p2 <- liftBuild $ Prim.mapP runReaderT p1     r <- ask-    liftBuild $ Prim.executeP p2 r+    liftBuild $ do+        p2 <- Prim.mapP runReaderT p1+        Prim.executeP p2 r  observeE :: Event (Moment a) -> Event a  observeE = liftCached1 $ executeP  executeE :: Event (Moment a) -> Moment (Event a) executeE e = do-    p      <- runCached e-    result <- executeP p-    return $ fromPure result+    -- Run cached computation later to allow more recursion with `Moment`+    p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e+    return $ fromPure p  switchE :: Event (Moment (Event a)) -> Event a switchE = liftCached1 $ \p1 -> do

@@ -17,7 +17,7 @@     stepperB, pureB, applyB, mapB,     -- ** Dynamic event switching     Moment,-    initialB, trimE, trimB, observeE, switchE, switchB,+    valueB, trimE, trimB, observeE, switchE, switchB,              -- * Interpretation     interpret,@@ -111,8 +111,8 @@     m >>= g = \time -> g (m time) time -} -initialB :: Behavior a -> Moment a-initialB (StepperB x _) = return x+valueB :: Behavior a -> Moment a+valueB (StepperB x _) = return x  trimE :: Event a -> Moment (Moment (Event a)) trimE e = \now -> \later -> drop (later - now) e

@@ -1,6 +1,7 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim (     -- * Synopsis     -- | This is an internal module, useful if you want to@@ -12,9 +13,12 @@     Step, Network, emptyNetwork,          -- * Build FRP networks-    Build, liftIOLater, BuildIO, BuildT, liftBuild, compile,+    Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,     module Control.Monad.IO.Class,     +    -- * Caching+    module Reactive.Banana.Prim.Cached,+         -- * Testing     interpret, mapAccumM, mapAccumM_, runSpaceProfile,     @@ -31,12 +35,85 @@          -- * Dynamic event switching     switchL, executeP, switchP+    +    -- * Notes+    -- $recursion   ) where   import Control.Monad.IO.Class+import Reactive.Banana.Prim.Cached import Reactive.Banana.Prim.Combinators import Reactive.Banana.Prim.Compile import Reactive.Banana.Prim.IO-import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, liftIOLater)+import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater) import Reactive.Banana.Prim.Types++{-----------------------------------------------------------------------------+    Notes+------------------------------------------------------------------------------}+-- Note [Recursion]+{- $recursion++The 'Build' monad is an instance of 'MonadFix' and supports value recursion.+However, it is built on top of the 'IO' monad, so the recursion is+somewhat limited.++The main rule for value recursion in the 'IO' monad is that the action+to be performed must be known in advance. For instance, the following snippet+will not work, because 'putStrLn' cannot complete its action without+inspecting @x@, which is not defined until later.++>   mdo+>       putStrLn x+>       let x = "Hello recursion"++On the other hand, whenever the sequence of 'IO' actions can be known+before inspecting any later arguments, the recursion works.+For instance the snippet++>   mdo+>       p1 <- mapP p2+>       p2 <- neverP+>       return p1++works because 'mapP' does not inspect its argument. In other words,+a call @p1 <- mapP undefined@ would perform the same sequence of 'IO' actions.+(Internally, it essentially calls 'newIORef'.)++With this issue in mind, almost all operations that build 'Latch'+and 'Pulse' values have been carefully implemented to not inspect+their arguments.+In conjunction with the 'Cached' mechanism for observable sharing,+this allows us to build combinators that can be used recursively.+One notable exception is the 'readLatch' function, which must+inspect its argument in order to be able to read its value.++-}++test :: Build (Pulse ())+test = mdo+    p1 <- mapP (const ()) p2+    p2 <- neverP+    return p1++-- Note [LatchStrictness]+{-++Any value that is stored in the graph over a longer+period of time must be stored in WHNF.++This implies that the values in a latch must be forced to WHNF+when storing them. That doesn't have to be immediately+since we are tying a knot, but it definitely has to be done+before  evaluateGraph  is done.++It also implies that reading a value from a latch must+be forced to WHNF before storing it again, so that we don't+carry around the old collection of latch values.+This is particularly relevant for `applyL`.++Conversely, since latches are the only way to store values over time,+this is enough to guarantee that there are no space leaks in this regard.++-}

@@ -7,16 +7,15 @@     -- and then retrieving values from a cache.     --      -- Very useful for observable sharing.-    HasCache(..),     Cached, runCached, cache, fromPure, don'tCache,     liftCached1, liftCached2,     ) where -import           Control.Monad-import           Control.Monad.Fix-import           Data.Unique.Really-import qualified Data.Vault.Lazy    as Lazy (Key, newKey)-import           System.IO.Unsafe           (unsafePerformIO)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.IORef+import System.IO.Unsafe       (unsafePerformIO)  {-----------------------------------------------------------------------------     Cache type@@ -26,44 +25,39 @@ runCached :: Cached m a -> m a runCached (Cached x) = x --- | Type class for monads that have a lazy 'Vault' that can be used as a cache.------ The cache has to be lazy in the values in order to be useful for recursion.-class (Monad m, MonadFix m) => HasCache m where-    retrieve :: Lazy.Key a -> m (Maybe a)-    write    :: Lazy.Key a -> a -> m ()- -- | An action whose result will be cached. -- Executing the action the first time in the monad will -- execute the side effects. From then on, -- only the generated value will be returned. {-# NOINLINE cache #-}-cache :: HasCache m => m a -> Cached m a+cache :: (MonadFix m, MonadIO m) => m a -> Cached m a cache m = unsafePerformIO $ do-    key <- Lazy.newKey+    key <- liftIO $ newIORef Nothing     return $ Cached $ do-        ma <- retrieve key      -- look up calculation result+        ma <- liftIO $ readIORef key    -- read the cached result         case ma of+            Just a  -> return a         -- return the cached result.             Nothing -> mdo-                write key a     -- black-hole result first-                a <- m          -- evaluate+                liftIO $                -- write the result already+                    writeIORef key (Just a)+                a <- m                  -- evaluate                 return a-            Just a  -> return a -- return cached result  -- | Return a pure value. Doesn't make use of the cache.-fromPure :: HasCache m => a -> Cached m a+fromPure :: Monad m => a -> Cached m a fromPure = Cached . return  -- | Lift an action that is /not/ chached, for instance because it is idempotent.-don'tCache :: HasCache m => m a -> Cached m a+don'tCache :: Monad m => m a -> Cached m a don'tCache = Cached -liftCached1 :: HasCache m => (a -> m b) -> Cached m a -> Cached m b+liftCached1 :: (MonadFix m, MonadIO m) =>+    (a -> m b) -> Cached m a -> Cached m b liftCached1 f ca = cache $ do     a <- runCached ca     f a -liftCached2 :: HasCache m =>+liftCached2 :: (MonadFix m, MonadIO m) =>     (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c liftCached2 f ca cb = cache $ do     a <- runCached ca

@@ -8,13 +8,14 @@ import Control.Monad import Control.Monad.IO.Class -import Reactive.Banana.Prim.Dated (Box(..)) import Reactive.Banana.Prim.Plumbing     ( neverP, newPulse, newLatch, cachedLatch-    , dependOn, changeParent-    , readPulseP, readLatchP, readLatchFutureP, liftBuildP, liftBuildIOP+    , dependOn, keepAlive, changeParent+    , getValueL+    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,     )-import Reactive.Banana.Prim.Types (Latch(..), Future, Pulse, Build, BuildIO)+import qualified Reactive.Banana.Prim.Plumbing (pureL)+import           Reactive.Banana.Prim.Types    (Latch, Future, Pulse, Build)  import Debug.Trace -- debug s = trace s@@ -78,15 +79,15 @@     return p  pureL :: a -> Latch a-pureL a = Latch { getValueL = return (pure a) }+pureL = Reactive.Banana.Prim.Plumbing.pureL  -- specialization of   mapL f = applyL (pureL f) mapL :: (a -> b) -> Latch a -> Latch b-mapL f lx = cachedLatch $ {-# SCC mapL #-} fmap f <$> getValueL lx+mapL f lx = cachedLatch $ {-# SCC mapL #-} f <$> getValueL lx  applyL :: Latch (a -> b) -> Latch a -> Latch b applyL lf lx = cachedLatch $-    {-# SCC applyL #-} (<*>) <$> getValueL lf <*> getValueL lx+    {-# SCC applyL #-} getValueL lf <*> getValueL lx  accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) accumL a p1 = do@@ -108,15 +109,15 @@ switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a) switchL l pl = mdo     x <- stepperL l pl-    return $ Latch { getValueL = getValueL x >>= \(Box a) -> getValueL a }+    return $ cachedLatch $ getValueL x >>= getValueL -executeP :: Pulse (b -> BuildIO a) -> b -> Build (Pulse a)+executeP :: Pulse (b -> Build a) -> b -> Build (Pulse a) executeP p1 b = do         p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1         p2 `dependOn` p1         return p2     where-    eval (Just x) = Just <$> liftBuildIOP (x b)+    eval (Just x) = Just <$> liftBuildP (x b)     eval Nothing  = return Nothing  switchP :: Pulse (Pulse a) -> Build (Pulse a)@@ -137,55 +138,5 @@     p1 <- newPulse "switchP_in" switch :: Build (Pulse ())     p1 `dependOn` pp     p2 <- newPulse "switchP_out" eval+    p2 `keepAlive` p1     return p2--{------------------------------------------------------------------------------    Notes-------------------------------------------------------------------------------}-{---* Note [PulseCreation]--We assume that we do not have to calculate a pulse occurrence-at the moment we create the pulse. Otherwise, we would have-to recalculate the dependencies *while* doing evaluation;-this is a recipe for desaster.--* Note [unsafePerformIO]--We're using @unsafePerformIO@ only to get @Key@ and @Unique@.-It's not great, but it works.--Unfortunately, using @IO@ as the base of the @Network@ monad-transformer doens't work because it doesn't support recursion-and @mfix@ very well.--We could use the @ST@ monad, but this would add a type parameter-to everything. A refactoring of this scope is too annoying for-my taste right now.--* Note [LatchRecursion]--...--* Note [LatchStrictness]--Any value that is stored in the graph over a longer-period of time must be stored in WHNF.--This implies that the values in a latch must be forced to WHNF-when storing them. That doesn't have to be immediately-since we are tying a knot, but it definitely has to be done-before  evaluateGraph  is done.--It also implies that reading a value from a latch must-be forced to WHNF before storing it again, so that we don't-carry around the old collection of latch values.-This is particularly relevant for `applyL`.--Conversely, since latches are the only way to store values over time,-this is enough to guarantee that there are no space leaks in this regard.---}--

@@ -1,13 +1,17 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}+{-# LANGUAGE BangPatterns #-} module Reactive.Banana.Prim.Compile where -import           Data.Functor-import           Data.IORef-import qualified Data.Vault.Lazy                  as Lazy+import Control.Exception (evaluate)+import Control.Monad     (void)+import Data.Functor+import Data.IORef+ import           Reactive.Banana.Prim.Combinators import           Reactive.Banana.Prim.IO+import qualified Reactive.Banana.Prim.OrderedBag  as OB import           Reactive.Banana.Prim.Plumbing import           Reactive.Banana.Prim.Types @@ -17,8 +21,26 @@ -- | Change a 'Network' of pulses and latches by  -- executing a 'BuildIO' action. compile :: BuildIO a -> Network -> IO (a, Network)-compile = flip runBuildIO+compile m state1 = do+    let time1    = nTime state1+        outputs1 = nOutputs state1 +    theAlwaysP <- case nAlwaysP state1 of+        Just x   -> return x+        Nothing  -> do+            (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())+            return x++    (a, topology, os) <- runBuildIO (nTime state1, theAlwaysP) m+    doit topology++    let state2 = Network+            { nTime    = next time1+            , nOutputs = foldr OB.insert outputs1 os+            , nAlwaysP = Just theAlwaysP+            }+    return (a,state2)+ {-----------------------------------------------------------------------------     Testing ------------------------------------------------------------------------------}@@ -30,10 +52,9 @@ -- that the 'sequence' function does not compute its result lazily. interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b] interpret f xs = do-    key <- Lazy.newKey     o   <- newIORef Nothing     let network = do-            (pin, sin) <- liftBuild $ newInput key+            (pin, sin) <- liftBuild $ newInput             pmid       <- f pin             pout       <- liftBuild $ mapP return pmid             liftBuild $ addHandler pout (writeIORef o . Just)@@ -52,17 +73,24 @@          mapAccumM go state xs         -- run several steps --- | Execute an FRP network with a sequence of inputs, but discard results.+-- | Execute an FRP network with a sequence of inputs.+-- Make sure that outputs are evaluated, but don't display their values. --  -- Mainly useful for testing whether there are space leaks. -runSpaceProfile :: (Pulse a -> BuildIO void) -> [a] -> IO ()+runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO () runSpaceProfile f xs = do-    key <- Lazy.newKey     let g = do-        (p1, fire) <- liftBuild $ newInput key-        f p1+        (p1, fire) <- liftBuild $ newInput+        p2 <- f p1+        p3 <- mapP return p2                -- wrap into Future+        addHandler p3 (\b -> void $ evaluate b)         return fire-    (fire,network) <- compile g emptyNetwork+    (step,network) <- compile g emptyNetwork++    let fire x s1 = do+            (outputs, s2) <- step x s1+            outputs                     -- don't forget to execute outputs+            return ((), s2)          mapAccumM_ fire network xs @@ -76,8 +104,8 @@  -- | Strict 'mapAccum' for a monad. Discards results. mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()-mapAccumM_ _ _  []     = return ()-mapAccumM_ f s0 (x:xs) = do+mapAccumM_ _ _   []     = return ()+mapAccumM_ f !s0 (x:xs) = do     (_,s1) <- f x s0     mapAccumM_ f s1 xs 

@@ -1,106 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Prim.Dated (-    -- | A cache with timestamps.-    -    -- * Time-    Time, ancient, beginning, next,-    -- * Cache-    Vault, Key, empty, newKey, findWithDefault,-    -- * Strictness-    Box(..),-    -- * Computations-    Dated, runDated, update', cache,-    -    ) where--import           Control.Applicative               hiding (empty)-import           Control.Monad.Trans.RWS-import           Data.Functor-import           Data.Monoid-import qualified Data.Vault.Strict       as Strict-import           Prelude                           hiding (lookup)--{------------------------------------------------------------------------------    Time monoid-------------------------------------------------------------------------------}-newtype Time = T Integer deriving (Eq, Ord, Show, Read)--ancient :: Time-ancient = T 0--beginning :: Time-beginning = T 1--next :: Time -> Time-next (T n) = T (n+1)--instance Monoid Time where-    mappend (T x) (T y) = T (max x y)-    mempty              = ancient--{------------------------------------------------------------------------------    Strictness-------------------------------------------------------------------------------}--- | A strict box of potentially lazy value.-data Box a = Box { unBox :: a }--instance Functor Box where-    fmap f (Box x) = Box (f x)--instance Applicative Box where-    pure x = Box x-    (Box f) <*> (Box x) = Box (f x)--{------------------------------------------------------------------------------    Cache data type-------------------------------------------------------------------------------}-newKey :: IO (Key a)-newKey = Strict.newKey--empty :: Vault-empty = Strict.empty--type Vault = Strict.Vault-type Key a = Strict.Key (Timed a)--{------------------------------------------------------------------------------    Cached computations-------------------------------------------------------------------------------}-type Dated   = RWS () Time Vault-data Timed a = Timed !(Box a) !Time--runDated :: Dated a -> Vault -> (a, Vault)-runDated m s1 = let (a,s2,_) = runRWS m () s1 in (a,s2)--findWithDefault :: a -> Key a -> Dated (Box a)-findWithDefault a key = do-    ma <- Strict.lookup key <$> get-    case ma of-        Nothing          -> return (Box a)-        Just (Timed a t) -> tell t >> return a---- | Update a value inside the cache.--- The value will be evaluated to WHNF when the cache is evaluated to WHNF.-update' :: Key a -> Time -> a -> Vault -> Vault-update' key t a = Strict.insert key (Timed (a `seq` Box a) t)--cache :: Key a -> Dated (Box a) -> Dated (Box a)--- cache key m = m--- Observation: If  a  is a function type, then forcing--- it will not necessarily remove all the function application things.-cache key m = do-    (aNew, timeNew) <- listen m-    let refresh = do-            modify $ Strict.insert key (Timed aNew timeNew)-            return aNew-    -    ma <- Strict.lookup key <$> get-    case ma of-        Just (Timed aOld timeOld)-            | timeOld >= timeNew -> do          -- cache is more recent -                                    tell timeOld-                                    return aOld-            | otherwise          -> refresh     -- cache is too old-        Nothing                  -> refresh

@@ -1,172 +1,107 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Reactive.Banana.Prim.Dependencies (-    -- | Utilities for operating with dependency graphs.-    Deps, dOrder, empty, allChildren, children, parents,-    addChild, changeParent,-    -    Continue(..), maybeContinue, traverseDependencies,-    -    DepsQueue, emptyQ, insert, minView,+    -- | Utilities for operating on node dependencies.+    addChild, changeParent, buildDependencies,     ) where -import           Control.Monad.Trans.Writer-import qualified Data.HashMap.Strict        as Map-import qualified Data.HashSet               as Set-import           Data.Hashable-import qualified Data.IntPSQ                as Q--import           Reactive.Banana.Prim.Order-import qualified Reactive.Banana.Prim.Order as Order+import Control.Monad+import Data.Functor+import Data.Monoid+import System.Mem.Weak -type Map = Map.HashMap-type Set = Set.HashSet+import qualified Reactive.Banana.Prim.Graph as Graph+import           Reactive.Banana.Prim.Types+import           Reactive.Banana.Prim.Util  {------------------------------------------------------------------------------    Dependency graph+    Accumulate dependency information for nodes ------------------------------------------------------------------------------}--- | A dependency graph.-data Deps a = Deps-    { dChildren :: Map a [a]     -- children depend on their parents-    , dParents  :: Map a [a]-    , dOrder    :: Order a-    } deriving (Show)---- | Representation of the depencencies as an association list of nodes--- to children.-allChildren :: Deps a -> [(a, [a])]-allChildren = Map.toList . dChildren---- | Children of a node.-children deps x =-    {-# SCC children #-} maybe [] id . Map.lookup x $ dChildren deps---- | Parents of a node.-parents  deps x = maybe [] id . Map.lookup x $ dParents  deps---- | The empty dependency graph.-empty :: Hashable a => Deps a-empty = Deps-    { dChildren = Map.empty-    , dParents  = Map.empty-    , dOrder    = Order.flat-    }+-- | Add a new child node to a parent node.+addChild :: SomeNode -> SomeNode -> DependencyBuilder+addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty) --- | Add a new dependency.-addChild :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-addChild parent child deps1@(Deps{..}) = deps2-    where-    deps2 = Deps-        { dChildren = Map.insertWith (++) parent [child] dChildren-        , dParents  = Map.insertWith (++) child [parent] dParents-        , dOrder    = ensureAbove child parent dOrder-        }-    when b f = if b then f else id+-- | Assign a new parent to a child node.+-- INVARIANT: The child may have only one parent node.+changeParent :: Pulse a -> Pulse b -> DependencyBuilder+changeParent child parent = (mempty, [(P child, P parent)]) --- | Change the parent of the first argument to be the second one.-changeParent :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-changeParent child parent deps1@(Deps{..}) = deps2+-- | Execute the information in the dependency builder+-- to change network topology.+buildDependencies :: DependencyBuilder -> IO ()+buildDependencies (Endo f, parents) = do+    sequence_ [x `doAddChild` y | x <- Graph.listParents gr, y <- Graph.getChildren gr x]+    sequence_ [x `doChangeParent` y | (P x, P y) <- parents]     where-    deps2 = Deps-        { dChildren = Map.insertWith (++) parent [child]-                    $ removeChild parentsOld dChildren-        , dParents  = Map.insert child [parent] dParents-        , dOrder    = recalculateParent child parent (parents deps2) dOrder-        }-    parentsOld   = parents deps1 child-    removeChild1 = Map.adjust (filter (/= child))-    removeChild  = concatenate . map removeChild1-    concatenate  = foldr (.) id+    gr = f Graph.emptyGraph  {------------------------------------------------------------------------------    Traversal+    Set dependencies of individual notes ------------------------------------------------------------------------------}--- | Data type for signaling whether to continue a traversal or not.-data Continue = Children | Done-    deriving (Eq, Ord, Show, Read)---- | Convert a 'Maybe' value into a 'Continue' decision.-maybeContinue :: Maybe a -> Continue-maybeContinue Nothing  = Done-maybeContinue (Just _) = Children---- | Starting with a set of root nodes, peform a monadic action--- for each node. If the action returns 'Children', its children will also--- be traversed at some point.--- However, all nodes are traversed in dependency order:--- A child node is only traversed when all its parent nodes have been traversed.-traverseDependencies :: forall a m. (Eq a, Hashable a, Monad m)-    => (a -> m Continue) -> Deps a -> [a] -> m ()-traverseDependencies f deps roots = go $ insertList roots emptyQ-    where-    order = dOrder deps-    insertList xs q = foldr (\x -> insert (level x order) x) q xs+-- | Add a child node to the children of a parent 'Pulse'.+connectChild+    :: Pulse a  -- ^ Parent node whose '_childP' field is to be updated.+    -> SomeNode -- ^ Child node to add.+    -> IO (Weak SomeNode)+                -- ^ Weak reference with the child as key and the parent as value.+connectChild parent child = do+    w <- mkWeakNodeValue child child+    modify' parent $ update childrenP (w:)+    mkWeakNodeValue child (P parent)        -- child keeps parent alive -    go q1 = case minView q1 of-        Nothing      -> return ()-        Just (a, q2) -> do-            continue <- f a-            case continue of-                Done     -> go q2-                Children -> go $ insertList (children deps a) q2+-- | Add a child node to a parent node and update evaluation order.+doAddChild :: SomeNode -> SomeNode -> IO ()+doAddChild (P parent) (P child) = do+    level1 <- _levelP <$> readRef child+    level2 <- _levelP <$> readRef parent+    let level = level1 `max` (level2 + 1)+    w <- parent `connectChild` (P child)+    modify' child $ set levelP level . update parentsP (w:)+doAddChild (P parent) node = void $ parent `connectChild` node --- | Queue for traversing dependencies.------ The 'Int' is a key supply for the priority search queue.-data DepsQueue a = DQ !(Q.IntPSQ Level a) !(Set a) Int+-- | Remove a node from its parents and all parents from this node.+removeParents :: Pulse a -> IO ()+removeParents child = do+    c@Pulse{_parentsP} <- readRef child+    -- delete this child (and dead children) from all parent nodes+    forM_ _parentsP $ \w -> do+        Just (P parent) <- deRefWeak w  -- get parent node+        finalize w                      -- severe connection in garbage collector+        let isGoodChild w = not . maybe True (== P child) <$> deRefWeak w+        new <- filterM isGoodChild . _childrenP =<< readRef parent+        modify' parent $ set childrenP new+    -- replace parents by empty list+    put child $ c{_parentsP = []} -emptyQ :: DepsQueue a-emptyQ = DQ Q.empty Set.empty 0+-- | Set the parent of a pulse to a different pulse.+doChangeParent :: Pulse a -> Pulse b -> IO ()+doChangeParent child parent = do+    -- remove all previous parents and connect to new parent+    removeParents child+    w <- parent `connectChild` (P child)+    modify' child $ update parentsP (w:) -insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a-insert k a q@(DQ queue seen n) = {-# SCC insert #-}-    if a `Set.member` seen-        then q-        else DQ (Q.insert (n+1) k a queue) (Set.insert a seen) (n+1)+    -- calculate level difference between parent and node+    levelParent <- _levelP <$> readRef parent+    levelChild  <- _levelP <$> readRef child+    let d = levelParent - levelChild + 1+    -- level parent - d = level child - 1 -minView :: DepsQueue a -> Maybe (a, DepsQueue a)-minView (DQ queue seen n) = {-# SCC minView #-} case Q.minView queue of-    Nothing                -> Nothing-    Just (_, _, a, queue2) -> Just (a, DQ queue2 seen n)+    -- lower all parents of the node if the parent was higher than the node+    when (d > 0) $ do+        parents <- Graph.dfs (P parent) getParents+        forM_ parents $ \(P node) -> do+            modify' node $ update levelP (subtract d)  {------------------------------------------------------------------------------    Small tests+    Helper functions ------------------------------------------------------------------------------}-test1 = id-    . changeParent 'C' 'A'-    . addChild 'C' 'D'-    . addChild 'B' 'C'-    . addChild 'B' 'D'-    . addChild 'A' 'B'-    . addChild 'a' 'B'-    $ empty--{- test2 =-        a-       / \-      b   d   A-      |   |   |-      c   e   B-       \ / \ /-        f   g-         \ /-          h---}-test2 = id-    . addChild 'g' 'h' . addChild 'e' 'g'-    . addChild 'B' 'g' . addChild 'A' 'B'-    . addChild 'f' 'h'-    . addChild 'e' 'f' . addChild 'd' 'e' . addChild 'a' 'd'-    . addChild 'c' 'f' . addChild 'b' 'c' . addChild 'a' 'b'-    $ empty--test3 = changeParent 'A' 'f' $ test2+getChildren :: SomeNode -> IO [SomeNode]+getChildren (P p) = deRefWeaks =<< fmap _childrenP (readRef p)+getChildren _     = return [] -listChildren :: (Eq a, Hashable a) => Deps a -> a -> [a]-listChildren deps x = snd $ runWriter $ traverseDependencies f deps [x]-    where f x = tell [x] >> return Children-    +getParents :: SomeNode -> IO [SomeNode]+getParents (P p) = deRefWeaks =<< fmap _parentsP (readRef p)+getParents _     = return []

@@ -1,75 +1,120 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, BangPatterns #-}-module Reactive.Banana.Prim.Evaluation where+{-# LANGUAGE RecordWildCards, BangPatterns #-}+module Reactive.Banana.Prim.Evaluation (+    step+    ) where -import qualified Control.Exception    as Strict (evaluate)-import           Data.Monoid-import           Data.List (foldl')+import qualified Control.Exception                  as Strict (evaluate)+import           Control.Monad                                (foldM)+import           Control.Monad                                (join)+import           Control.Monad.IO.Class+import qualified Control.Monad.Trans.RWSIO          as RWS+import qualified Control.Monad.Trans.ReaderWriterIO as RW+import           Data.Functor+import           Data.Maybe+import qualified Data.PQueue.Prio.Min               as Q+import qualified Data.Vault.Lazy                    as Lazy+import           System.Mem.Weak -import qualified Reactive.Banana.Prim.Dated        as Dated-import qualified Reactive.Banana.Prim.Dependencies as Deps-import           Reactive.Banana.Prim.Order+import qualified Reactive.Banana.Prim.OrderedBag as OB import           Reactive.Banana.Prim.Plumbing import           Reactive.Banana.Prim.Types+import           Reactive.Banana.Prim.Util +type Queue = Q.MinPQueue Level+ {------------------------------------------------------------------------------    Graph evaluation+    Evaluation step ------------------------------------------------------------------------------} -- | Evaluate all the pulses in the graph, -- Rebuild the graph as necessary and update the latch values. step :: Inputs -> Step-step (pulse1, roots) state1 = {-# SCC step #-} mdo-    let graph1 = nGraph state1-        latch1 = nLatchValues state1-        time1  = nTime state1--    -- evaluate pulses while recalculating some latch values-    ((_, latchUpdates, output), state2)-            <- runBuildIO state1-            $  runEvalP pulse1-            $  evaluatePulses graph1 roots-    -    let-        -- updated graph dependencies-        graph2 = nGraph state2-        -- update latch values from accumulations-        latch2 = appEndo latchUpdates $ nLatchValues state2-        -- calculate output actions, possibly recalculating more latch values-        (actions, latch3) = Dated.runDated output latch2+step (inputs,pulses)+        Network{ nTime = time1+        , nOutputs = outputs1+        , nAlwaysP = Just alwaysP   -- we assume that this has been built already+        }+    = {-# SCC step #-} do -    -- make sure that the latch values are in WHNF-    Strict.evaluate $ {-# SCC evaluate #-} latch3-    return (actions, Network-            { nGraph       = graph2-            , nLatchValues = latch3-            , nTime        = Dated.next time1-            })+    -- evaluate pulses+    ((_, (latchUpdates, outputs)), topologyUpdates, os)+            <- runBuildIO (time1, alwaysP)+            $  runEvalP pulses+            $  evaluatePulses inputs +    doit latchUpdates                           -- update latch values from pulses+    doit topologyUpdates                        -- rearrange graph topology+    let actions = OB.inOrder outputs outputs1   -- EvalO actions in proper order+        state2  = Network+            { nTime    = next time1+            , nOutputs = foldr OB.insert outputs1 os+            , nAlwaysP = Just alwaysP+            }+    return (runEvalOs $ map snd actions, state2) -type Result = (EvalL, [(Position, EvalO)])-type Q      = Deps.DepsQueue+runEvalOs :: [EvalO] -> IO ()+runEvalOs = sequence_ . map join +{-----------------------------------------------------------------------------+    Traversal in dependency order+------------------------------------------------------------------------------} -- | Update all pulses in the graph, starting from a given set of nodes-evaluatePulses :: Graph -> [SomeNode] -> EvalP Result-evaluatePulses Graph { grDeps = deps } roots =-        go mempty [] $ insertList roots Deps.emptyQ+evaluatePulses :: [SomeNode] -> EvalP ()+evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty     where-    order = Deps.dOrder deps-    -    go :: EvalL -> [(Position,EvalO)] -> Q SomeNode -> EvalP Result-    go el eo !q1 = {-# SCC go #-} case Deps.minView q1 of-        Nothing      -> return (el, eo)-        Just (a, q2) -> case a of-            P p -> evaluateP p >>= \c -> case c of-                Deps.Children -> go el eo $ insertList (Deps.children deps a) q2-                Deps.Done     -> go el eo q2-            L l -> evaluateL l >>= \x -> go (el `mappend` x) eo      q2-            O o -> evaluateO o >>= \x -> go el ((positionO o, x):eo) q2--    insertList :: [SomeNode] -> Q SomeNode -> Q SomeNode-    insertList xs q = {-# SCC insertList #-}-        foldl' (\q node -> Deps.insert (level node order) node q) q xs+    -- go :: Queue SomeNode -> EvalP ()+    go r q = {-# SCC go #-}+        case ({-# SCC minView #-} Q.minView q) of+            Nothing         -> return ()+            Just (node, q)  -> do+                children <- unwrapEvalP r (evaluateNode node)+                q        <- insertNodes r children q+                go r q +-- | Recalculate a given node and return all children nodes+-- that need to evaluated subsequently.+evaluateNode :: SomeNode -> EvalP [SomeNode]+evaluateNode (P p) = {-# SCC evaluateNodeP #-} do+    Pulse{..} <- readRef p+    ma        <- _evalP+    writePulseP _keyP ma+    case ma of+        Nothing -> return []+        Just _  -> liftIO $ deRefWeaks _childrenP+evaluateNode (L lw) = {-# SCC evaluateNodeL #-} do+    time           <- askTime+    LatchWrite{..} <- readRef lw+    mlatch         <- liftIO $ deRefWeak _latchLW -- retrieve destination latch+    case mlatch of+        Nothing    -> return ()+        Just latch -> do+            a <- _evalLW                    -- calculate new latch value+            -- liftIO $ Strict.evaluate a      -- see Note [LatchStrictness]+            rememberLatchUpdate $           -- schedule value to be set later+                modify' latch $ \l ->+                    a `seq` l { _seenL = time, _valueL = a }+    return []+evaluateNode (O o) = {-# SCC evaluateNodeO #-} do+    debug "evaluateNode O"+    Output{..} <- readRef o+    m          <- _evalO                    -- calculate output action+    rememberOutput $ (o,m)+    return [] +-- | Insert nodes into the queue+-- insertNode :: [SomeNode] -> Queue SomeNode -> EvalP (Queue SomeNode)+insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go+    where+    go []              q = return q+    go (node@(P p):xs) q = do+        Pulse{..} <- readRef p+        if time <= _seenP+            then go xs q        -- pulse has already been put into the queue once+            else do             -- pulse needs to be scheduled for evaluation+                put p $! (let p = Pulse{..} in p { _seenP = time })+                go xs (Q.insert _levelP node q)+    go (node:xs)      q = go xs (Q.insert ground node q)+            -- O and L nodes have only one parent, so+            -- we can insert them at an arbitrary level

@@ -0,0 +1,77 @@+{-----------------------------------------------------------------------------+    reactive-banana+    +    Implementation of graph-related functionality+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Graph where++import           Control.Monad+import           Data.Functor.Identity+import qualified Data.HashMap.Strict   as Map+import qualified Data.HashSet          as Set+import           Data.Hashable+import           Data.Maybe++{-----------------------------------------------------------------------------+    Graphs and topological sorting+------------------------------------------------------------------------------}+data Graph a = Graph+    { children :: Map.HashMap a [a]+    , parents  :: Map.HashMap a [a]+    , nodes    :: Set.HashSet a+    }++-- | The graph with no edges and no nodes.+emptyGraph :: Graph a+emptyGraph = Graph Map.empty Map.empty Set.empty++-- | Insert an edge from the first node to the second node into the graph.+insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a+insertEdge (x,y) gr = gr+    { children = Map.insertWith (flip (++)) x [y] (children gr)+    , parents  = Map.insertWith (flip (++)) y [x] (parents  gr)+    , nodes    = Set.insert x $ Set.insert y $ nodes gr+    }++-- | Get all immediate children of a node in a graph.+getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a]+getChildren gr x = maybe [] id . Map.lookup x . children $ gr++-- | Get all immediate parents of a node in a graph.+getParents :: (Eq a, Hashable a) => Graph a -> a -> [a]+getParents gr x = maybe [] id . Map.lookup x . parents $ gr++-- | List all nodes such that each parent is listed before all of its children.+listParents :: (Eq a, Hashable a) => Graph a -> [a]+listParents gr = list+    where+    -- all nodes without children+    ancestors = [x | x <- Set.toList $ nodes gr, null (getParents gr x)]+    -- all nodes in topological order "parents before children"+    list      = runIdentity $ dfs' ancestors (Identity . getChildren gr)++{-----------------------------------------------------------------------------+    Graph traversal+------------------------------------------------------------------------------}+-- | Graph represented as map of successors.+type GraphM m a = a -> m [a]++-- | Depth-first search. List all transitive successors of a node.+-- A node is listed *before* all its successors have been listed.+dfs :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]+dfs x = dfs' [x]++-- | Depth-first serach, refined version.+-- INVARIANT: None of the nodes in the initial list have a predecessor.+dfs' :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]+dfs' xs succs = liftM fst $ go xs [] Set.empty+    where+    go []     ys seen            = return (ys, seen)    -- all nodes seen+    go (x:xs) ys seen+        | x `Set.member` seen    = go xs ys seen+        | otherwise              = do+            xs' <- succs x+            -- visit all children+            (ys', seen') <- go xs' ys (Set.insert x seen)+            -- list this node as all successors have been seen+            go xs (x:ys') seen'

@@ -1,19 +1,19 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.IO where +import           Control.Monad.IO.Class import           Data.Functor-import           Data.Unique.Really-import qualified Data.Vault.Strict  as Strict-import qualified Data.Vault.Lazy    as Lazy-import           System.IO.Unsafe             (unsafePerformIO)+import           Data.IORef+import qualified Data.Vault.Lazy        as Lazy -import Reactive.Banana.Prim.Combinators  (mapP)-import Reactive.Banana.Prim.Dependencies (maybeContinue)-import Reactive.Banana.Prim.Evaluation   (step)+import Reactive.Banana.Prim.Combinators (mapP)+import Reactive.Banana.Prim.Evaluation  (step) import Reactive.Banana.Prim.Plumbing import Reactive.Banana.Prim.Types+import Reactive.Banana.Prim.Util  debug s = id @@ -24,19 +24,22 @@ -- -- Together with 'addHandler', this function can be used to operate with -- pulses as with standard callback-based events.-newInput :: Lazy.Key a -> Build (Pulse a, a -> Step)-newInput key = unsafePerformIO $ do-    uid <- newUnique-    let pulse = Pulse-            { evaluateP = maybeContinue <$> readPulseP pulse-            , getValueP = Lazy.lookup key-            , uidP      = uid-            , nameP     = "newInput"-            }-    return $ do-        always <- alwaysP-        let inputs a = (Lazy.insert key a Lazy.empty, [P pulse, P always])-        return (pulse, step . inputs)+newInput :: Build (Pulse a, a -> Step)+newInput = mdo+    always <- alwaysP+    key    <- liftIO $ Lazy.newKey+    pulse  <- liftIO $ newRef $ Pulse+        { _keyP      = key+        , _seenP     = agesAgo+        , _evalP     = readPulseP pulse    -- get its own value+        , _childrenP = []+        , _parentsP  = []+        , _levelP    = ground+        , _nameP     = "newInput"+        }+    -- Also add the  alwaysP  pulse to the inputs.+    let run a = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty)+    return (pulse, run)  -- | Register a handler to be executed whenever a pulse occurs. --

@@ -1,90 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, BangPatterns, RecordWildCards #-}-module Reactive.Banana.Prim.Order (-    -- * Synopsis-    -- | Data structure that represents a partial ordering by levels.-    -    -- * Order-    Order, flat,-    ensureAbove, recalculateParent,-    Level, level,-    -    ) where--import Data.Functor-import qualified Data.HashMap.Strict as Map-import qualified Data.HashSet        as Set-import           Data.Hashable-import qualified Data.IntMap.Strict  as IntMap--type IntMap = IntMap.IntMap-type Map    = Map.HashMap-type Set    = Set.HashSet--{------------------------------------------------------------------------------    Order by levels-------------------------------------------------------------------------------}--- | Each element is assigned a /level/.--- Elements in lower levels come before elements in higher levels.--- There is no order on elements within the same level.-type Order a = Map a Level---- | FIXME: Level should be an 'Integer' to avoid overflow.------ FIXME: The algorithms in this module currently do not try to--- shrink the number or width of levels.-type Level   = Integer---- | The flat order where every element is at 'ground' level.-flat :: Order a-flat = Map.empty---- | Ground level.-ground :: Level-ground = 0---- | Look up the level of an element. Default level is 'ground'.-level :: (Eq a, Hashable a) => a -> Order a -> Level-level x = {-# SCC level #-} maybe ground id . Map.lookup x---- | Make sure that the first argument is at least one level--- above the second argument.-ensureAbove :: (Eq a, Hashable a) => a -> a -> Order a -> Order a-ensureAbove child parent order =-    Map.insertWith max child (level parent order + 1) order---- | Reassign the parent for a child and recalculate the levels--- for the new parents and grandparents.-recalculateParent :: (Eq a, Hashable a)-    => a       -- Child.-    -> a       -- Parent.-    -> Graph a -- Query parents of a node. -    -> Order a -> Order a-recalculateParent child parent parents order-    | d <= 0    = order-    | otherwise = concatenate-        [ Map.insertWith (+) node (-d) | node <- dfs parent parents ]-        order-    where-    d = level parent order - level child order + 1-    -- level parent - d = level child - 1-    concatenate = foldr (.) id--{------------------------------------------------------------------------------    Graph traversal-------------------------------------------------------------------------------}--- | Graph represented as map of successors.-type Graph a = a -> [a]---- | Depth-first search. List all transitive successors of a node.-dfs :: (Eq a, Hashable a) => a -> Graph a -> [a]-dfs x succs = go [x] Set.empty-    where-    go []     _               = []-    go (x:xs) seen-        | x `Set.member` seen = go xs seen-        | otherwise           = x : go (ys ++ xs) (Set.insert x seen)-        where-        ys = succs x

@@ -0,0 +1,35 @@+{-----------------------------------------------------------------------------+    reactive-banana+    +    Implementation of a bag whose elements are ordered by arrival time.+------------------------------------------------------------------------------}+{-# LANGUAGE TupleSections #-}+module Reactive.Banana.Prim.OrderedBag where++import           Data.Functor+import qualified Data.HashMap.Strict as Map+import           Data.Hashable+import           Data.List+import           Data.Maybe+import           Data.Ord++{-----------------------------------------------------------------------------+    Ordered Bag+------------------------------------------------------------------------------}+type Position = Integer++data OrderedBag a = OB !(Map.HashMap a Position) !Position++empty :: OrderedBag a+empty = OB Map.empty 0++-- | Add an element to an ordered bag after all the others.+-- Does nothing if the element is already in the bag.+insert :: (Eq a, Hashable a) => a -> OrderedBag a -> OrderedBag a+insert x (OB xs n) = OB (Map.insertWith (\new old -> old) x n xs) (n+1)++-- | Reorder a list of elements to appear as they were inserted into the bag.+-- Remove any elements from the list that do not appear in the bag.+inOrder :: (Eq a, Hashable a) => [(a,b)] -> OrderedBag a -> [(a,b)]+inOrder xs (OB bag _) = map snd $ sortBy (comparing fst) $+    mapMaybe (\x -> (,x) <$> Map.lookup (fst x) bag) xs

@@ -1,163 +1,249 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE RecordWildCards, RecursiveDo, BangPatterns #-} module Reactive.Banana.Prim.Plumbing where -import           Control.Monad-import           Control.Monad.Fix+import           Control.Monad                                (join)+import           Control.Monad.IO.Class import           Control.Monad.Trans.Class-import           Control.Monad.Trans.RWS-import qualified Control.Monad.Trans.State as State-import           Data.Function+import qualified Control.Monad.Trans.RWSIO          as RWS+import qualified Control.Monad.Trans.Reader         as Reader+import qualified Control.Monad.Trans.ReaderWriterIO as RW+import           Data.Function                                (on) import           Data.Functor-import           Data.Functor.Identity-import           Data.List+import           Data.IORef+import           Data.List                                    (sortBy) import           Data.Monoid-import           Data.Unique.Really-import qualified Data.Vault.Lazy           as Lazy-import           System.IO.Unsafe                  (unsafePerformIO)+import qualified Data.Vault.Lazy                    as Lazy+import           System.IO.Unsafe -import           Reactive.Banana.Prim.Cached                (HasCache(..))-import qualified Reactive.Banana.Prim.Dated        as Dated import qualified Reactive.Banana.Prim.Dependencies as Deps import           Reactive.Banana.Prim.Types+import           Reactive.Banana.Prim.Util  {-----------------------------------------------------------------------------     Build primitive pulses and latches ------------------------------------------------------------------------------} -- | Make 'Pulse' from evaluation function newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)-newPulse name eval = unsafePerformIO $ do+newPulse name eval = liftIO $ do     key <- Lazy.newKey-    uid <- newUnique-    return $ do-        let write = maybe (return Deps.Done) ((Deps.Children <$) . writePulseP key)-        return $ Pulse-            { evaluateP = {-# SCC evaluateP #-} write =<< eval-            , getValueP = Lazy.lookup key-            , uidP      = uid-            , nameP     = name-            }+    newRef $ Pulse+        { _keyP      = key+        , _seenP     = agesAgo+        , _evalP     = eval+        , _childrenP = []+        , _parentsP  = []+        , _levelP    = ground+        , _nameP     = name+        } +{-+* Note [PulseCreation]++We assume that we do not have to calculate a pulse occurrence+at the moment we create the pulse. Otherwise, we would have+to recalculate the dependencies *while* doing evaluation;+this is a recipe for desaster.++-}+ -- | 'Pulse' that never fires. neverP :: Build (Pulse a)-neverP = unsafePerformIO $ do-    uid <- newUnique-    return $ return $ Pulse-        { evaluateP = return Deps.Done-        , getValueP = const Nothing-        , uidP      = uid-        , nameP     = "neverP"+neverP = liftIO $ do+    key <- Lazy.newKey+    newRef $ Pulse+        { _keyP      = key+        , _seenP     = agesAgo+        , _evalP     = return Nothing+        , _childrenP = []+        , _parentsP  = []+        , _levelP    = ground+        , _nameP     = "neverP"         } --- | Make new 'Latch' that can be updated.+-- | Return a 'Latch' that has a constant value+pureL :: a -> Latch a+pureL a = unsafePerformIO $ newRef $ Latch+    { _seenL  = beginning+    , _valueL = a+    , _evalL  = return a+    }++-- | Make new 'Latch' that can be updated by a 'Pulse' newLatch :: a -> Build (Pulse a -> Build (), Latch a)-newLatch a = unsafePerformIO $ do-    key <- Dated.newKey-    uid <- newUnique-    return $ do-        let-            write time   = maybe mempty (Endo . Dated.update' key time)-            latchWrite p = LatchWrite-                { evaluateL = {-# SCC evaluateL #-} do-                    time <- lift $ nTime <$> get-                    write (Dated.next time) <$> readPulseP p-                , uidL      = uid+newLatch a = mdo+    latch <- liftIO $ newRef $ Latch+        { _seenL  = beginning+        , _valueL = a+        , _evalL  = do+            Latch {..} <- readRef latch+            RW.tell _seenL  -- indicate timestamp+            return _valueL  -- indicate value+        }+    let+        err        = error "incorrect Latch write"+        updateOn p = do+            w  <- liftIO $ mkWeakRefValue latch latch +            lw <- liftIO $ newRef $ LatchWrite+                { _evalLW  = maybe err id <$> readPulseP p+                , _latchLW = w                 }-            updateOn p   = P p `addChild` L (latchWrite p)-        return-            (updateOn, Latch { getValueL = Dated.findWithDefault a key })+            -- writer is alive only as long as the latch is alive+            _  <- liftIO $ mkWeakRefValue latch lw+            (P p) `addChild` (L lw)+    +    return (updateOn, latch) --- | Make a new 'Latch' that caches a previous computation-cachedLatch :: Dated.Dated (Dated.Box a) -> Latch a-cachedLatch eval = unsafePerformIO $ do-    key <- Dated.newKey-    return $ Latch { getValueL = {-# SCC getValueL #-} Dated.cache key eval }+-- | Make a new 'Latch' that caches a previous computation.+cachedLatch :: EvalL a -> Latch a+cachedLatch eval = unsafePerformIO $ mdo+    latch <- newRef $ Latch+        { _seenL  = agesAgo+        , _valueL = error "Undefined value of a cached latch."+        , _evalL  = do+            Latch{..} <- liftIO $ readRef latch+            -- calculate current value (lazy!) with timestamp+            (a,time)  <- RW.listen eval+            liftIO $ if time <= _seenL+                then return _valueL     -- return old value+                else do                 -- update value+                    let _seenL  = time+                    let _valueL = a+                    a `seq` put latch (Latch {..})+                    return a+        }+    return latch  -- | Add a new output that depends on a 'Pulse'. -- -- TODO: Return function to unregister the output again. addOutput :: Pulse EvalO -> Build ()-addOutput p = unsafePerformIO $ do-    uid <- newUnique-    return $ do-        pos <- grOutputCount . nGraph <$> get-        let o = Output-                { evaluateO = {-# SCC evaluateO #-} maybe nop id <$> readPulseP p-                , uidO      = uid-                , positionO = pos-                }-        modify $ updateGraph $ updateOutputCount $ (+1)-        P p `addChild` O o+addOutput p = do+    o <- liftIO $ newRef $ Output+        { _evalO = maybe (return $ debug "nop") id <$> readPulseP p+        }+    (P p) `addChild` (O o)+    RW.tell $ BuildW (mempty, [o], mempty, mempty)  {------------------------------------------------------------------------------    Build monad - add and delete nodes from the graph+    Build monad ------------------------------------------------------------------------------}-runBuildIO :: Network -> BuildIO a -> IO (a, Network)-runBuildIO s1 m = {-# SCC runBuildIO #-} do-    (a,s2,liftIOLaters) <- runRWST m () s1-    sequence_ liftIOLaters          -- execute late IOs-    return (a,s2)+runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])+runBuildIO i m = {-# SCC runBuild #-} do+        (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m+        doit $ liftIOLaters          -- execute late IOs+        return (a,Action $ Deps.buildDependencies topologyUpdates,os)+    where+    -- Recursively execute the  buildLater  calls.+    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)+    unfold w m = do+        (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i+        let w' = w <> BuildW (w1,w2,w3,mempty)+        w'' <- case later of+            Just m  -> snd <$> unfold w' m+            Nothing -> return w'+        return (a,w'') --- Lift a pure  Build  computation into any monad.--- See note [BuildT]-liftBuild :: Monad m => Build a -> BuildT m a-liftBuild m = RWST $ \r s -> return . runIdentity $ runRWST m r s+buildLater :: Build () -> Build ()+buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x) -readLatchB :: Latch a -> Build a-readLatchB latch = state $ \network ->-    let (a,v) = Dated.runDated (getValueL latch) (nLatchValues network)-    in  (Dated.unBox a, network { nLatchValues = v } )+-- | Pretend to return a value right now,+-- but do not actually calculate it until later.+--+-- NOTE: Accessing the value before it's written leads to an error.+--+-- FIXME: Is there a way to have the value calculate on demand?+buildLaterReadNow :: Build a -> Build a+buildLaterReadNow m = do+    ref <- liftIO $ newIORef $+        error "buildLaterReadNow: Trying to read before it is written."+    buildLater $ m >>= liftIO . writeIORef ref+    liftIO $ unsafeInterleaveIO $ readIORef ref +liftBuild :: Build a -> BuildIO a+liftBuild = id++getTimeB :: Build Time+getTimeB = (\(x,_) -> x) <$> RW.ask+ alwaysP :: Build (Pulse ())-alwaysP = grAlwaysP . nGraph <$> get+alwaysP = (\(_,x) -> x) <$> RW.ask -instance (MonadFix m, Functor m) => HasCache (BuildT m) where-    retrieve key = Lazy.lookup key . grCache . nGraph <$> get-    write key a  = modify $ updateGraph $ updateCache $ Lazy.insert key a+readLatchB :: Latch a -> Build a+readLatchB = liftIO . readLatchIO  dependOn :: Pulse child -> Pulse parent -> Build () dependOn child parent = (P parent) `addChild` (P child) -changeParent :: Pulse child -> Pulse parent -> Build ()-changeParent child parent =-    modify . updateGraph . updateDeps $ Deps.changeParent (P child) (P parent)+keepAlive :: Pulse child -> Pulse parent -> Build ()+keepAlive child parent = liftIO $ mkWeakRefValue child parent >> return ()  addChild :: SomeNode -> SomeNode -> Build () addChild parent child =-    modify . updateGraph . updateDeps $ Deps.addChild parent child+    RW.tell $ BuildW (Deps.addChild parent child, mempty, mempty, mempty) +changeParent :: Pulse child -> Pulse parent -> Build ()+changeParent node parent =+    RW.tell $ BuildW (Deps.changeParent node parent, mempty, mempty, mempty)+ liftIOLater :: IO () -> Build ()-liftIOLater x = tell [x]+liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty)  {------------------------------------------------------------------------------    EvalP - evaluate pulses+    EvalL monad ------------------------------------------------------------------------------}-runEvalP :: Lazy.Vault -> EvalP (EvalL, [(Position, EvalO)])-    -> BuildIO (Lazy.Vault, EvalL, EvalO)-runEvalP pulse m = do-        ((wl,wo),s) <- State.runStateT m pulse-        return (s,wl, sequence_ <$> sequence (sortOutputs wo))-    where-    sortOutputs = map snd . sortBy (compare `on` fst)+-- | Evaluate a latch (-computation) at the latest time,+-- but discard timestamp information.+readLatchIO :: Latch a -> IO a+readLatchIO latch = do+    Latch{..} <- readRef latch+    liftIO $ fst <$> RW.runReaderWriterIOT _evalL () -readLatchP :: Latch a -> EvalP a-readLatchP = {-# SCC readLatchP #-} lift . liftBuild . readLatchB+getValueL :: Latch a -> EvalL a+getValueL latch = do+    Latch{..} <- readRef latch+    _evalL -readLatchFutureP :: Latch a -> EvalP (Future a)-readLatchFutureP latch = State.state $ \s -> (Dated.unBox <$> getValueL latch,s)+{-----------------------------------------------------------------------------+    EvalP monad+------------------------------------------------------------------------------}+runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)+runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do+    (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1+    return ((a,w1), w2) -writePulseP :: Lazy.Key a -> a -> EvalP ()-writePulseP key a = {-# SCC writePulseP #-} State.modify $ Lazy.insert key a+liftBuildP :: Build a -> EvalP a+liftBuildP m = RWS.rwsT $ \r2 s -> do+    (a,w2) <- RW.runReaderWriterIOT m r2+    return (a,s,(mempty,w2)) +askTime :: EvalP Time+askTime = fst <$> RWS.ask+ readPulseP :: Pulse a -> EvalP (Maybe a)-readPulseP pulse = {-# SCC readPulseP #-} getValueP pulse <$> State.get+readPulseP p = do+    Pulse{..} <- readRef p+    join . Lazy.lookup _keyP <$> RWS.get -liftBuildIOP :: BuildIO a -> EvalP a-liftBuildIOP = lift+writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()+writePulseP key a = do+    s <- RWS.get+    RWS.put $ Lazy.insert key a s -liftBuildP :: Build a -> EvalP a-liftBuildP = liftBuildIOP . liftBuild+readLatchP :: Latch a -> EvalP a+readLatchP = liftBuildP . readLatchB +readLatchFutureP :: Latch a -> EvalP (Future a)+readLatchFutureP = return . readLatchIO +rememberLatchUpdate :: IO () -> EvalP ()+rememberLatchUpdate x = RWS.tell ((Action x,mempty),mempty)++rememberOutput :: (Output, EvalO) -> EvalP ()+rememberOutput x = RWS.tell ((mempty,[x]),mempty)++-- worker wrapper to break sharing and support better inlining+unwrapEvalP r m = RWS.run m r+wrapEvalP   m   = RWS.R m

@@ -28,6 +28,8 @@     let l2  =  mapL const l1     return p2 +-- test garbage collection+ {-----------------------------------------------------------------------------     Space leak tests ------------------------------------------------------------------------------}

@@ -1,194 +1,214 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Reactive.Banana.Prim.Types where -import           Control.Monad.Trans.Class-import           Control.Monad.Trans.RWS.Lazy-import           Control.Monad.Trans.State-import           Data.Functor.Identity-import qualified Data.HashMap.Strict          as Map-import qualified Data.HashSet                 as Set+import           Control.Monad.Trans.RWSIO+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.ReaderWriterIO+import           Data.Functor import           Data.Hashable import           Data.Monoid-import           Data.Unique.Really-import qualified Data.Vault.Lazy              as Lazy-import           System.IO.Unsafe                       (unsafePerformIO)--import           Reactive.Banana.Prim.Cached-import qualified Reactive.Banana.Prim.Dated        as Dated-import qualified Reactive.Banana.Prim.Dependencies as Deps+import qualified Data.Vault.Lazy                    as Lazy+import           System.IO.Unsafe+import           System.Mem.Weak -type Deps = Deps.Deps+import Reactive.Banana.Prim.Graph            (Graph)+import Reactive.Banana.Prim.OrderedBag as OB (OrderedBag, empty)+import Reactive.Banana.Prim.Util  {------------------------------------------------------------------------------    Graph+    Network ------------------------------------------------------------------------------}--- | A 'Graph' represents the connections between pulses and events.-data Graph = Graph-    { grDeps        :: Deps SomeNode   -- dependency information-    , grCache       :: Lazy.Vault      -- cache for the monad-    , grAlwaysP     :: Pulse ()        -- special pulse that always fires-    , grOutputCount :: !Position       -- ensure declaration order-    }-type Position = Integer--instance Show Graph where show = showDeps . grDeps- -- | A 'Network' represents the state of a pulse/latch network,--- which consists of a 'Graph' and the values of all accumulated latches--- in the network. data Network = Network-    { nGraph       :: Graph-    , nLatchValues :: Dated.Vault-    , nTime        :: Dated.Time+    { nTime           :: !Time                 -- Current time.+    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.+    , nAlwaysP        :: !(Maybe (Pulse ()))   -- Pulse that always fires.     } -instance Show Network where show = show . nGraph+instance Show Network where show = error "instance Show Network not implemented." -type Inputs        = (Lazy.Vault, [SomeNode])+type Inputs        = ([SomeNode], Lazy.Vault) type EvalNetwork a = Network -> IO (a, Network) type Step          = EvalNetwork (IO ()) --- | Lenses for the 'Graph' and the 'Network' type-updateGraph       f = \s -> s { nGraph       = f (nGraph s) }-updateLatchValues f = \s -> s { nLatchValues = f (nLatchValues s) }-updateDeps        f = \s -> s { grDeps       = f (grDeps s) }-updateCache       f = \s -> s { grCache      = f (grCache s) }-updateOutputCount f = \s -> s { grOutputCount = f (grOutputCount s) }--emptyGraph :: Graph-emptyGraph = unsafePerformIO $ do-    uid <- newUnique-    return $ Graph-        { grDeps        = Deps.empty-        , grCache       = Lazy.empty-        , grAlwaysP     = Pulse-            { evaluateP = return Deps.Children-            , getValueP = const $ Just ()-            , uidP      = uid-            , nameP     = "alwaysP"-            }-        , grOutputCount = 0-        }---- | The 'Network' that contains no pulses or latches.-emptyNetwork :: Network emptyNetwork = Network-    { nGraph       = emptyGraph-    , nLatchValues = Dated.empty-    , nTime        = Dated.beginning+    { nTime    = next beginning+    , nOutputs = OB.empty+    , nAlwaysP = Nothing     } --- The 'Build' monad is used to change the graph, for example to--- * add nodes--- * change dependencies--- * add inputs or outputs-type BuildT  = RWST () BuildConf Network-type Build   = BuildT Identity -type BuildIO = BuildT IO--type BuildConf = [IO ()] -- liftIOLater+type Build  = ReaderWriterIOT BuildR BuildW IO+type BuildR = (Time, Pulse ())+    -- ( current time+    -- , pulse that always fires)+newtype BuildW = BuildW (DependencyBuilder, [Output], Action, Maybe (Build ()))+    -- reader : current timestamp+    -- writer : ( actions that change the network topology+    --          , outputs to be added to the network+    --          , late IO actions+    --          , late build actions+    --          ) -{- Note [BuildT]+instance Monoid BuildW where+    mempty                          = BuildW mempty+    (BuildW x) `mappend` (BuildW y) = BuildW (x `mappend` y) -It is very convenient to be able to perform some IO functions-while (re)building a network graph. At the same time,-we need a good  MonadFix  instance to build recursive networks.-These requirements clash, so the solution is to split the types-into a pure variant and IO variant, the former having a good-MonadFix  instance while the latter can do arbitrary IO.+type BuildIO = Build --}+type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)])  {------------------------------------------------------------------------------    Pulse and Latch+    Synonyms ------------------------------------------------------------------------------}-{--    evaluateL/P-        calculates the next value and makes sure that it's cached-    getValueL/P-        retrieves the current value-    uidL/P-        used for dependency tracking and evaluation order-    nameP-        used for debugging--}+-- | Priority used to determine evaluation order for pulses.+type Level = Int -data Pulse a = Pulse-    { evaluateP :: EvalP Deps.Continue-    , getValueP :: Lazy.Vault -> Maybe a-    , uidP      :: Unique-    , nameP     :: String-    }+ground :: Level+ground = 0 -data Latch a = Latch-    { getValueL :: Future (Dated.Box a)-    }+-- | 'IO' actions as a monoid with respect to sequencing.+newtype Action = Action { doit :: IO () }+instance Monoid Action where+    mempty = Action $ return ()+    (Action x) `mappend` (Action y) = Action (x >> y) -data LatchWrite = LatchWrite-    { evaluateL :: EvalP EvalL-    , uidL      :: Unique-    }+-- | Lens-like functionality.+data Lens s a = Lens (s -> a) (a -> s -> s)+set    (Lens _   set)   = set+update (Lens get set) f = \s -> set (f $ get s) s -data Output = Output-    { evaluateO :: EvalP EvalO-    , uidO      :: Unique-    , positionO :: Position+{-----------------------------------------------------------------------------+    Pulse and Latch+------------------------------------------------------------------------------}+type Pulse  a = Ref (Pulse' a)+data Pulse' a = Pulse+    { _keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.+    , _seenP     :: !Time              -- See note [Timestamp].+    , _evalP     :: EvalP (Maybe a)    -- Calculate current value.+    , _childrenP :: [Weak SomeNode]    -- Weak references to child nodes.+    , _parentsP  :: [Weak SomeNode]    -- Weak reference to parent nodes.+    , _levelP    :: !Level             -- Priority in evaluation order.+    , _nameP     :: String             -- Name for debugging.     } -type EvalP = StateT Lazy.Vault BuildIO-    -- state: current pulse values+instance Show (Pulse a) where+    show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p) -type Future = Dated.Dated-type EvalL  = Endo Dated.Vault-type EvalO  = Future (IO ())+type Latch  a = Ref (Latch' a)+data Latch' a = Latch+    { _seenL  :: !Time               -- Timestamp for the current value.+    , _valueL :: a                   -- Current value.+    , _evalL  :: EvalL a             -- Recalculate current latch value.+    }+type LatchWrite = Ref LatchWrite'+data LatchWrite' = forall a. LatchWrite+    { _evalLW  :: EvalP a            -- Calculate value to write.+    , _latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.+    } -nop :: EvalO-nop = return $ return ()+type Output  = Ref Output'+data Output' = Output+    { _evalO     :: EvalP EvalO+    }+instance Eq Output where (==) = equalRef --- | Existential quantification for dependency tracking data SomeNode     = forall a. P (Pulse a)     | L LatchWrite     | O Output -instance Show SomeNode where show = show . hash+instance Hashable SomeNode where+    hashWithSalt s (P x) = hashWithSalt s x+    hashWithSalt s (L x) = hashWithSalt s x+    hashWithSalt s (O x) = hashWithSalt s x  instance Eq SomeNode where-    (P x) == (P y)  =  uidP x == uidP y-    (L x) == (L y)  =  uidL x == uidL y-    (O x) == (O y)  =  uidO x == uidO y-    _     == _      =  False+    (P x) == (P y) = equalRef x y+    (L x) == (L y) = equalRef x y+    (O x) == (O y) = equalRef x y -uid :: SomeNode -> Unique-uid (P x) = uidP x-uid (L x) = uidL x-uid (O x) = uidO x+{-# INLINE mkWeakNodeValue #-}+mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)+mkWeakNodeValue (P x) = mkWeakRefValue x+mkWeakNodeValue (L x) = mkWeakRefValue x+mkWeakNodeValue (O x) = mkWeakRefValue x -instance Hashable SomeNode where-    hashWithSalt s = hashWithSalt s . uid+-- Lenses for various parameters+seenP  = Lens _seenP  (\a s -> s { _seenP = a })+seenL  = Lens _seenL  (\a s -> s { _seenL = a })+valueL = Lens _valueL (\a s -> s { _valueL = a })+parentsP  = Lens _parentsP (\a s -> s { _parentsP = a })+childrenP = Lens _childrenP (\a s -> s { _childrenP = a })+levelP = Lens _levelP (\a s -> s { _levelP = a }) +-- | Evaluation monads.+type EvalPW   = (EvalLW, [(Output, EvalO)])+type EvalLW   = Action++type EvalO    = Future (IO ())+type Future   = IO++-- Note: For efficiency reasons, we unroll the monad transformer stack.+-- type EvalP = RWST () Lazy.Vault EvalPW Build+type EvalP    = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO+    -- writer : (latch updates, IO action)+    -- state  : current pulse values++-- Computation with a timestamp that indicates the last time it was performed.+type EvalL    = ReaderWriterIOT () Time IO+ {-----------------------------------------------------------------------------     Show functions for debugging ------------------------------------------------------------------------------}-showDeps :: Deps SomeNode -> String-showDeps deps = unlines $-        [ detail node ++-          if null children then "" else " -> " ++ unwords (map short children)-        | node <- nodes-        , let children = Deps.children deps node-        ]-    where-    allChildren = Deps.allChildren deps-    nodes       = Set.toList . Set.fromList $-                  concat [x : xs | (x,xs) <- allChildren]-    dictionary  = Map.fromList $ zip nodes [1..]-    -    short node = maybe "X" show $ Map.lookup node dictionary-    -    detail (P x) = "P " ++ nameP x ++ " " ++ short (P x)-    detail (L x) = "L " ++ short (L x)-    detail (O x) = "O " ++ short (O x)+printNode :: SomeNode -> IO String+printNode (P p) = _nameP <$> readRef p+printNode (L l) = return "L"+printNode (O o) = return "O" +{-----------------------------------------------------------------------------+    Time monoid+------------------------------------------------------------------------------}+-- | A timestamp local to this program run.+--+-- Useful e.g. for controlling cache validity.+newtype Time = T Integer deriving (Eq, Ord, Show, Read)++-- | Before the beginning of time. See Note [TimeStamp]+agesAgo :: Time+agesAgo = T (-1)++beginning :: Time+beginning = T 0++next :: Time -> Time+next (T n) = T (n+1)++instance Monoid Time where+    mappend (T x) (T y) = T (max x y)+    mempty              = beginning++{-----------------------------------------------------------------------------+    Notes+------------------------------------------------------------------------------}+{- Note [Timestamp]++The time stamp indicates how recent the current value is.++For Pulse:+During pulse evaluation, a time stamp equal to the current+time indicates that the pulse has already been evaluated in this phase.++For Latch:+The timestamp indicates the last time at which the latch has been written to.++    agesAgo   = The latch has never been written to.+    beginning = The latch has been written to before everything starts.++The second description is ensured by the fact that the network+writes timestamps that begin at time `next beginning`.++-}

@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE MagicHash, UnboxedTuples #-}+module Reactive.Banana.Prim.Util where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Hashable+import           Data.IORef+import           Data.Maybe                    (catMaybes)+import           Data.Unique.Really+import qualified GHC.Base               as GHC+import qualified GHC.IORef              as GHC+import qualified GHC.STRef              as GHC+import qualified GHC.Weak               as GHC+import           System.Mem.Weak++debug :: MonadIO m => String -> m ()+-- debug = liftIO . putStrLn+debug _ = return ()++nop :: Monad m => m ()+nop = return ()++{-----------------------------------------------------------------------------+    IORefs that can be hashed+------------------------------------------------------------------------------}+data Ref a = Ref !(IORef a) !Unique++instance Hashable (Ref a) where hashWithSalt s (Ref _ u) = hashWithSalt s u ++equalRef :: Ref a -> Ref b -> Bool+equalRef (Ref _ a) (Ref _ b) = a == b++newRef :: MonadIO m => a -> m (Ref a)+newRef a = liftIO $ liftM2 Ref (newIORef a) newUnique++readRef :: MonadIO m => Ref a -> m a+readRef ~(Ref ref _) = liftIO $ readIORef ref++put :: MonadIO m => Ref a -> a -> m ()+put ~(Ref ref _) = liftIO . writeIORef ref++-- | Strictly modify an 'IORef'.+modify' :: MonadIO m => Ref a -> (a -> a) -> m ()+modify' ~(Ref ref _) f = liftIO $ readIORef ref >>= \x -> writeIORef ref $! f x++{-----------------------------------------------------------------------------+    Weak pointers+------------------------------------------------------------------------------}+mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value)+mkWeakIORefValueFinalizer r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->+  case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)++mkWeakIORefValue :: IORef a -> value -> IO (Weak value)+mkWeakIORefValue a b = mkWeakIORefValueFinalizer a b (return ())++mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value)+mkWeakRefValue (Ref ref _) v = liftIO $ mkWeakIORefValue ref v++-- | Dereference a list of weak pointers while discarding dead ones.+deRefWeaks :: [Weak v] -> IO [v]+deRefWeaks ws = {-# SCC deRefWeaks #-} fmap catMaybes $ mapM deRefWeak ws

@@ -88,8 +88,14 @@     . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE  -- | Obtain the value of the 'Behavior' at moment @t@.+--+-- NOTE: The value is immediately available for pattern matching.+-- Unfortunately, this means that @valueB@ is unsuitable for use+-- with value recursion in the 'Moment' monad.+--+-- If you need recursion, please use 'initial' instead. valueB :: Behavior t a -> Moment t a-valueB = M . Prim.initialB . unB+valueB = M . Prim.valueB . unB  -- | Dynamically switch between 'Event'. switchE

@@ -33,6 +33,7 @@         [ testModelMatch "counter"     counter         , testModelMatch "double"      double         , testModelMatch "sharing"     sharing+        , testModelMatch "unionFilter" unionFilter         , testModelMatch "recursive1"  recursive1         , testModelMatch "recursive2"  recursive2         , testModelMatch "recursive3"  recursive3@@ -43,12 +44,16 @@     , testGroup "Dynamic Event Switching"         [ testModelMatch  "observeE_id"         observeE_id         , testModelMatchM "initialB_immediate"  initialB_immediate-        , testModelMatchM "initialB_recursive1" initialB_recursive1-        , testModelMatchM "initialB_recursive2" initialB_recursive2+        -- , testModelMatchM "initialB_recursive1" initialB_recursive1+        -- , testModelMatchM "initialB_recursive2" initialB_recursive2+        , testModelMatchM "trimB_recursive"     trimB_recursive         , testModelMatchM "dynamic_apply"       dynamic_apply         , testModelMatchM "switchE1"            switchE1         , testModelMatchM "switchB_two"         switchB_two         ]+    , testGroup "Regression tests"+        [ testModelMatch "issue79" issue79+        ]     -- TODO:     --  * algebraic laws     --  * larger examples@@ -105,10 +110,16 @@  merge e1 e2 = unionWith (++) (list e1) (list e2)     where list = fmap (:[])-    + double e  = merge e e sharing e = merge e1 e1     where e1 = filterE (< 3) e++unionFilter e1 = unionWith (+) e2 e3+    where+    e3 = fmap (+1) $ filterE even e1+    e2 = fmap (+1) $ filterE odd  e1+ recursive1 e1 = e2     where     e2 = applyE b e1@@ -121,7 +132,7 @@  type Dummy = Int --- counter that can be decreased as long as it's >= 0+-- Counter that can be decreased as long as it's >= 0 . recursive3 :: Event Dummy -> Event Int recursive3 edec = applyE (const <$> bcounter) ecandecrease     where@@ -157,38 +168,45 @@         eq     = filterApply ((==) <$> result) input         neq    = filterApply ((/=) <$> result) input --- test accumE vs accumB+-- Test 'accumE' vs 'accumB'. accumBvsE :: Event Dummy -> Event [Int] accumBvsE e = merge e1 e2     where     e1 = accumE 0 ((+1) <$ e)     e2 = let b = accumB 0 ((+1) <$ e) in applyE (const <$> b) e - observeE_id = observeE . fmap return -- = id  initialB_immediate e = do-    x <- initialB (stepper 0 e)+    x <- valueB (stepper 0 e)     return $ x <$ e++{-- The following tests can no longer work with 'Build'+being a transformer of the 'IO' monad.+See Note [Recursion].+ initialB_recursive1 e1 = mdo     _ <- initialB b     let b = stepper 0 e1     return $ b <@ e1-    --- NOTE: This test case tries to reproduce a situation--- where the value of a latch is used before the latch was created.--- This was relevant for the CRUD example, but I can't find a way--- to make it smaller right now. Oh well.+ initialB_recursive2 e1 = mdo     x <- initialB b     let bf = const x <$ stepper 0 e1      let b  = stepper 0 $ (bf <*> b) <@ e1     return $ b <@ e1+-}  dynamic_apply e = do     mb <- trimB $ stepper 0 e-    return $ observeE $ (initialB =<< mb) <$ e+    return $ observeE $ (valueB =<< mb) <$ e     -- = stepper 0 e <@ e++trimB_recursive e = mdo+    let e2 = observeE $ (valueB =<< mb) <$ e+    mb <- trimB $ stepper 0 e+    return e2+ switchE1 e = do     me <- trimE e     return $ switchE $ me <$ e@@ -198,3 +216,19 @@     b0  <- mb0     let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e     return $ b <@ e++{-----------------------------------------------------------------------------+    Regression tests+------------------------------------------------------------------------------}+issue79 :: Event Dummy -> Event String+issue79 inputEvent = outputEvent+    where+    appliedEvent  = (\_ _ -> 1) <$> lastValue <@> inputEvent+    filteredEvent = filterE (const True) appliedEvent+    fmappedEvent  = fmap id (filteredEvent)+    lastValue     = stepper 1 $ fmappedEvent++    outputEvent = unionWith (++)+        (const "filtered event" <$> filteredEvent)+        (((" and " ++) . show) <$> unionWith (+) appliedEvent fmappedEvent)+

@@ -81,7 +81,7 @@     (fmap (fmap bx . mx) $ X.trimB x)     (fmap (fmap by . my) $ Y.trimB y) -initialB ~(B x y) = M (X.initialB x) (Y.initialB y)+valueB ~(B x y) = M (X.valueB x) (Y.valueB y)  observeE :: Event (Moment a) -> Event a observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y)

@@ -21,6 +21,7 @@ > type Event t a = [(Time,a)] -} newtype Event t a = E { unE :: Prim.Event [a] }+-- Invariant: The empty list `[]` never occurs as event value.  {-| @Behavior t a@ represents a value that varies in time. Think of it as