reactive-banana 1.2.2.0 → 1.3.0.0

raw patch · 43 files changed

+2315/−2158 lines, 43 filesdep +randomdep +tastydep +tasty-benchdep −HUnitdep −test-frameworkdep −test-framework-hunitdep ~basedep ~containersdep ~hashable

Dependencies added: random, tasty, tasty-bench, tasty-hunit

Dependencies removed: HUnit, test-framework, test-framework-hunit

Dependency ranges changed: base, containers, hashable, semigroups, transformers

Files

• CHANGELOG.md +21/−0
• benchmark/Main.hs +83/−0
• reactive-banana.cabal +36/−28
• src/Control/Event/Handler.hs +25/−5
• src/Control/Monad/Trans/RWSIO.hs +0/−8
• src/Control/Monad/Trans/ReaderWriterIO.hs +4/−13
• src/Reactive/Banana.hs +0/−1
• src/Reactive/Banana/Combinators.hs +42/−15
• src/Reactive/Banana/Frameworks.hs +4/−5
• src/Reactive/Banana/Internal/Combinators.hs +0/−246
• src/Reactive/Banana/Model.hs +7/−6
• src/Reactive/Banana/Prim.hs +0/−119
• src/Reactive/Banana/Prim/Cached.hs +0/−65
• src/Reactive/Banana/Prim/Combinators.hs +0/−150
• src/Reactive/Banana/Prim/Compile.hs +0/−110
• src/Reactive/Banana/Prim/Dependencies.hs +0/−108
• src/Reactive/Banana/Prim/Evaluation.hs +0/−124
• src/Reactive/Banana/Prim/Graph.hs +0/−102
• src/Reactive/Banana/Prim/High/Cached.hs +64/−0
• src/Reactive/Banana/Prim/High/Combinators.hs +250/−0
• src/Reactive/Banana/Prim/IO.hs +0/−56
• src/Reactive/Banana/Prim/Low/Compile.hs +110/−0
• src/Reactive/Banana/Prim/Low/Dependencies.hs +108/−0
• src/Reactive/Banana/Prim/Low/Evaluation.hs +119/−0
• src/Reactive/Banana/Prim/Low/Graph.hs +102/−0
• src/Reactive/Banana/Prim/Low/IO.hs +55/−0
• src/Reactive/Banana/Prim/Low/OrderedBag.hs +42/−0
• src/Reactive/Banana/Prim/Low/Plumbing.hs +250/−0
• src/Reactive/Banana/Prim/Low/Types.hs +227/−0
• src/Reactive/Banana/Prim/Low/Util.hs +63/−0
• src/Reactive/Banana/Prim/Mid.hs +113/−0
• src/Reactive/Banana/Prim/Mid/Combinators.hs +149/−0
• src/Reactive/Banana/Prim/Mid/Test.hs +39/−0
• src/Reactive/Banana/Prim/OrderedBag.hs +0/−43
• src/Reactive/Banana/Prim/Plumbing.hs +0/−254
• src/Reactive/Banana/Prim/Test.hs +0/−39
• src/Reactive/Banana/Prim/Types.hs +0/−237
• src/Reactive/Banana/Prim/Util.hs +0/−61
• src/Reactive/Banana/Test.hs +0/−253
• src/Reactive/Banana/Test/Plumbing.hs +0/−106
• src/Reactive/Banana/Types.hs +48/−4
• tests/Main.hs +248/−0
• tests/Plumbing.hs +106/−0

@@ -1,6 +1,27 @@ Changelog for the `reactive-banana** package ------------------------------------------- +**Unreleased**++* Increased upper bounds of `transformers`, `semigroups` and `hashable`+* Added `Semigroup` and `Monoid` instances to `Moment` and `MomentIO`. [#223][]+* Add `@>` operator. [#229][]+* `switchE` now takes an initial event. This is breaking change. The previous behavior can be restored by using `switchE never`. [#165][]+* Triggering an `AddHandler` no longer allocates, leading to a minor performance improvement. [#237][]+* A new `once` combinator has been added that filters an `Event` so it only fires once. [#239][]+* `MonadMoment` instances have been added for all possibly monad transformers (from the `transformers` library). [#248][]+* Some internal refactoring to reduce allocations and improve performance. [#238][]+* The `Reactive.Banana.Prim` hierarchy has been changed to better reflect the abstraction hierarchy. [#241][]++  [#165]: https://github.com/HeinrichApfelmus/reactive-banana/pull/165+  [#229]: https://github.com/HeinrichApfelmus/reactive-banana/pull/229+  [#223]: https://github.com/HeinrichApfelmus/reactive-banana/pull/223+  [#237]: https://github.com/HeinrichApfelmus/reactive-banana/pull/237+  [#238]: https://github.com/HeinrichApfelmus/reactive-banana/pull/238+  [#239]: https://github.com/HeinrichApfelmus/reactive-banana/pull/239+  [#241]: https://github.com/HeinrichApfelmus/reactive-banana/pull/241+  [#248]: https://github.com/HeinrichApfelmus/reactive-banana/pull/248+ **Version 1.2.2.0**  * Optimize the implementation of `Graph.listParents` [#209][]

@@ -0,0 +1,83 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NumericUnderscores #-}+module Main ( main ) where++import Control.Monad (replicateM, replicateM_, forM_)+import qualified Data.IntMap.Strict as IM+import Reactive.Banana.Combinators ( Event, Behavior, MonadMoment, filterE, accumE, switchB, accumB )+import Reactive.Banana.Frameworks (MomentIO, newAddHandler, fromAddHandler, compile, actuate, Handler, reactimate)+import Reactive.Banana ( Event, Behavior, MonadMoment )+import System.Random (randomRIO)+import Test.Tasty (withResource)+import Test.Tasty.Bench (env, defaultMain, bgroup, bench, whnfIO)++main :: IO ()+main = defaultMain $ [ mkBenchmarkGroup netsize | netsize <- [ 1, 2, 4, 8, 16, 32, 64, 128 ] ] +++                     [ boringBenchmark ]+  where+    mkBenchmarkGroup netsize =+      withResource (setupBenchmark netsize) mempty $ \getEnv ->+        bgroup ("netsize = " <> show netsize)+          [ mkBenchmark getEnv steps | steps <- [ 1, 2, 4, 8, 16, 32, 64, 128] ]+      where+        mkBenchmark getEnv duration = bench ("duration = " <> show duration) $ whnfIO $ do+          (triggers, clock) <- getEnv+          let trigMap = IM.fromList $ zip [0..netsize-1] triggers+          forM_ [1..duration] $ \step -> do+            randomRs <- replicateM 10 $ randomRIO (0,netsize-1)+            clock step+            forM_ randomRs $ \ev ->+                maybe (error "benchmark: trigger not found") ($ ()) $+                    IM.lookup ev trigMap++    boringBenchmark = withResource setup mempty $ \getEnv ->+      bench "Boring" $ whnfIO $ do+        tick <- getEnv+        {-# SCC ticks #-} replicateM_ 1_000_000 $ {-# SCC tick #-} tick ()+      where+        setup = do+          (tick, onTick) <- newAddHandler+          network <- compile $ do+            e <- fromAddHandler tick+            reactimate $ return <$> e+          actuate network+          return onTick++setupBenchmark :: Int -> IO ([Handler ()], Handler Int)+setupBenchmark netsize = do+  (handlers, triggers) <- unzip <$> replicateM netsize newAddHandler+  (clock   , trigger ) <- newAddHandler++  let networkD :: MomentIO ()+      networkD = do+          es :: [Event ()] <-+            mapM fromAddHandler handlers++          e :: Event Int <-+            fromAddHandler clock++          countBs :: [Behavior Int] <-+            traverse count es++          let+            step10E :: Event Int+            step10E = filterE (\cnt -> cnt `rem` 10 == 0) e++          selectedB_E :: Event (Behavior Int) <- do+            fmap head <$> accumE countBs (keepTail <$ step10E)++          selectedB :: Behavior Int <-+            switchB (head countBs) selectedB_E++          return ()++      count :: MonadMoment m => Event () -> m (Behavior Int)+      count e = accumB 0 ((+1) <$ e)++  actuate =<< compile networkD+  return (triggers, trigger)+  where+    keepTail :: [a] -> [a]+    keepTail (_:y:zs) = y:zs+    keepTail [x]      = [x]+    keepTail []       = []

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             1.2.2.0+Version:             1.3.0.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).@@ -25,13 +25,10 @@ Category:            FRP Cabal-version:       1.18 Build-type:          Simple-Tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 8.0.1,-                     GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1+Tested-with:         GHC == 8.4.3, GHC == 8.6.1  extra-source-files:     CHANGELOG.md,-                        doc/examples/*.hs,-                        src/Reactive/Banana/Test.hs,-                        src/Reactive/Banana/Test/Plumbing.hs+                        doc/examples/*.hs extra-doc-files:        doc/*.png  Source-repository head@@ -44,12 +41,12 @@     hs-source-dirs:     src      build-depends:      base >= 4.2 && < 5,-                        semigroups >= 0.13 && < 0.20,+                        semigroups >= 0.13 && < 0.21,                         containers >= 0.5 && < 0.7,-                        transformers >= 0.2 && < 0.6,+                        transformers >= 0.2 && < 0.7,                         vault == 0.3.*,                         unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.4,+                        hashable >= 1.1 && < 1.5,                         pqueue >= 1.0 && < 1.5,                         these >= 0.2 && < 1.2 @@ -59,35 +56,46 @@                         Reactive.Banana.Combinators,                         Reactive.Banana.Frameworks,                         Reactive.Banana.Model,-                        Reactive.Banana.Prim,-                        Reactive.Banana.Prim.Cached+                        Reactive.Banana.Prim.Mid,+                        Reactive.Banana.Prim.High.Cached      other-modules:                         Control.Monad.Trans.ReaderWriterIO,                         Control.Monad.Trans.RWSIO,-                        Reactive.Banana.Internal.Combinators,-                        Reactive.Banana.Prim.Combinators,-                        Reactive.Banana.Prim.Compile,-                        Reactive.Banana.Prim.Dependencies,-                        Reactive.Banana.Prim.Evaluation,-                        Reactive.Banana.Prim.Graph,-                        Reactive.Banana.Prim.IO,-                        Reactive.Banana.Prim.OrderedBag,-                        Reactive.Banana.Prim.Plumbing,-                        Reactive.Banana.Prim.Test,-                        Reactive.Banana.Prim.Types,-                        Reactive.Banana.Prim.Util,+                        Reactive.Banana.Prim.Low.Compile,+                        Reactive.Banana.Prim.Low.Dependencies,+                        Reactive.Banana.Prim.Low.Evaluation,+                        Reactive.Banana.Prim.Low.Graph,+                        Reactive.Banana.Prim.Low.IO,+                        Reactive.Banana.Prim.Low.OrderedBag,+                        Reactive.Banana.Prim.Low.Plumbing,+                        Reactive.Banana.Prim.Low.Types,+                        Reactive.Banana.Prim.Low.Util,+                        Reactive.Banana.Prim.Mid.Combinators,+                        Reactive.Banana.Prim.Mid.Test,+                        Reactive.Banana.Prim.High.Combinators,                         Reactive.Banana.Types+    +    ghc-options: -Wall -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-fields -Werror=partial-fields -Wno-name-shadowing  Test-Suite tests     default-language:   Haskell98     type:               exitcode-stdio-1.0-    hs-source-dirs:     src-    main-is:            Reactive/Banana/Test.hs+    hs-source-dirs:     tests+    main-is:            Main.hs+    other-modules:      Plumbing     build-depends:      base >= 4.2 && < 5,-                        HUnit >= 1.2 && < 2,-                        test-framework >= 0.6 && < 0.9,-                        test-framework-hunit >= 0.2 && < 0.4,+                        tasty,+                        tasty-hunit,                         reactive-banana, vault, containers,                         semigroups, transformers,                         unordered-containers, hashable, psqueues, pqueue, these+++Benchmark benchmark+  default-language:   Haskell2010+  type:          exitcode-stdio-1.0+  build-depends: base, tasty-bench, reactive-banana, containers, random, tasty+  hs-source-dirs: benchmark+  main-is: Main.hs+  ghc-options:  "-with-rtsopts=-A32m"

@@ -9,12 +9,11 @@     ) where  +import           Control.Monad ((>=>), when) import           Data.IORef import qualified Data.Map    as Map import qualified Data.Unique -type Map = Map.Map- {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}@@ -40,12 +39,12 @@  -- | Map the event value with an 'IO' action. mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b-mapIO f e = AddHandler $ \h -> register e $ \x -> f x >>= h+mapIO f e = AddHandler $ \h -> register e (f >=> h)  -- | Filter event values that don't return 'True'. filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a filterIO f e = AddHandler $ \h ->-    register e $ \x -> f x >>= \b -> if b then h x else return ()+    register e $ \x -> f x >>= \b -> when b $ h x  {-----------------------------------------------------------------------------     Construction@@ -68,8 +67,29 @@             atomicModifyIORef_ handlers $ Map.insert key handler             return $ atomicModifyIORef_ handlers $ Map.delete key         runHandlers a =-            mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers+            runAll a =<< readIORef handlers     return (AddHandler register, runHandlers)  atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())++-- | A callback is a @a -> IO ()@ function. We define this newtype to provide+-- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which+-- allow us to write the efficient 'runAll' function.+newtype Callback a = Callback { invoke :: a -> IO () }++instance Semigroup (Callback a) where+    Callback f <> Callback g = Callback $ \a -> f a >> g a++instance Monoid (Callback a) where+    mempty = Callback $ \_ -> return ()++-- This function can also be seen as+--+--   runAll a fs = mapM_ ($ a) fs+--+-- The reason we write this using 'foldMap' and 'Callback' is to produce code+-- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237+-- for more info.+runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO ()+runAll a fs = invoke (foldMap Callback fs) a

@@ -7,13 +7,10 @@     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@@ -92,8 +89,3 @@  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

@@ -8,14 +8,10 @@     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-import Data.Semigroup  {-----------------------------------------------------------------------------     Type and class instances@@ -40,17 +36,17 @@     mx <> my = mx >> my  instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where-    mempty          = return ()-    mx `mappend` my = mx >> my+    mempty  = return ()+    mappend = (<>)  {-----------------------------------------------------------------------------     Functions ------------------------------------------------------------------------------} liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a-liftIOR m = ReaderWriterIOT $ \x y -> liftIO m+liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m  liftR :: m a -> ReaderWriterIOT r w m a-liftR m = ReaderWriterIOT $ \x y -> m+liftR m = ReaderWriterIOT $ \_ _ -> m  fmapR :: Functor m => (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y)@@ -99,8 +95,3 @@  ask :: Monad m => ReaderWriterIOT r w m r ask = ReaderWriterIOT $ \r _ -> return r--test :: ReaderWriterIOT String String IO ()-test = do-    c <- ask-    tell c

@@ -19,7 +19,6 @@  import Reactive.Banana.Combinators import Reactive.Banana.Frameworks-import Reactive.Banana.Types  {-$intro 

@@ -2,6 +2,7 @@     reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Reactive.Banana.Combinators (@@ -34,9 +35,9 @@      -- * Derived Combinators     -- ** Infix operators-    (<@>), (<@),+    (<@>), (<@), (@>),     -- ** Filtering-    filterJust, filterApply, whenE, split,+    filterJust, filterApply, whenE, split, once,     -- ** Accumulation     -- $Accumulation.     unions, accumB, mapAccum,@@ -45,12 +46,10 @@     ) where  import Control.Applicative-import Control.Monad-import Data.Maybe          (isJust, catMaybes) import Data.Semigroup-import Data.These (These(..), these)+import Data.These (These(..)) -import qualified Reactive.Banana.Internal.Combinators as Prim+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  {-----------------------------------------------------------------------------@@ -277,12 +276,15 @@ -- | Dynamically switch between 'Event'. -- Semantically, ----- > switchE ee = \time0 -> concat [trim t1 t2 e | (t1,t2,e) <- intervals ee, time0 <= t1]--- >     where--- >     intervals e        = [(time1, time2, x) | ((time1,x),(time2,_)) <- zip e (tail e)]+-- > switchE e0 ee0 time0 =+-- >     concat [ trim t1 t2 e | (t1,t2,e) <- intervals ee ]+-- >   where+-- >     laterThan e time0  = [(timex,x) | (timex,x) <- e, time0 < timex ]+-- >     ee                 = [(time0, e0)] ++ (ee0 `laterThan` time0)+-- >     intervals ee       = [(time1, time2, e) | ((time1,e),(time2,_)) <- zip ee (tail ee)] -- >     trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2]-switchE :: MonadMoment m => Event (Event a) -> m (Event a)-switchE = liftMoment . M . fmap E . Prim.switchE . Prim.mapE (unE) . unE+switchE :: MonadMoment m => Event a -> Event (Event a) -> m (Event a)+switchE e ee = liftMoment (M (fmap E (Prim.switchE (unE e) (Prim.mapE unE (unE ee)))))  -- | Dynamically switch between 'Behavior'. -- Semantically,@@ -290,12 +292,12 @@ -- >  switchB b0 eb = \time0 -> \time1 -> -- >     last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1 switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a)-switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE (unB) . unE+switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE unB . unE  {-----------------------------------------------------------------------------     Derived Combinators ------------------------------------------------------------------------------}-infixl 4 <@>, <@+infixl 4 <@>, <@, @>  -- | Infix synonym for the 'apply' combinator. Similar to '<*>'. --@@ -309,6 +311,20 @@ (<@)  :: Behavior b -> Event a -> Event b f <@ g = (const <$> f) <@> g +-- | Tag all event occurences with a time-varying value. Similar to '*>'.+--+-- This is the flipped version of '<@', but can be useful when combined with+-- @ApplicativeDo@ to sample from multiple 'Behavior's:+--+-- @+-- reactimate $ onEvent @> do+--   x <- behavior1+--   y <- behavior2+--   return (print (x + y))+-- @+(@>) :: Event a -> Behavior b -> Event b+g @> f = (const <$> f) <@> g+ -- | Allow all events that fulfill the time-varying predicate, discard the rest. -- Generalization of 'filterE'. filterApply :: Behavior (a -> Bool) -> Event a -> Event a@@ -327,11 +343,22 @@     where     fromLeft :: Either a b -> Maybe a     fromLeft  (Left  a) = Just a-    fromLeft  (Right b) = Nothing+    fromLeft  (Right _) = Nothing      fromRight :: Either a b -> Maybe b-    fromRight (Left  a) = Nothing+    fromRight (Left  _) = Nothing     fromRight (Right b) = Just b+++-- | Keep only the next occurence of an event.+-- +-- @once@ also aids the garbage collector by indicating that the result event can be discarded after its only occurrence.+--+-- > once e = \time0 -> take 1 [(t, a) | (t, a) <- e, time0 <= t]+once :: MonadMoment m => Event a -> m (Event a)+once e = mdo+    e1 <- switchE e (never <$ e1)+    return e1   -- $Accumulation.

@@ -42,7 +42,7 @@ import           Control.Monad.IO.Class import           Data.IORef import           Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.Combinators as Prim+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  @@ -342,7 +342,7 @@ -- inside a 'reactimate'. newEvent :: MomentIO (Event a, Handler a) newEvent = do-    (addHandler, fire) <- liftIO $ newAddHandler+    (addHandler, fire) <- liftIO newAddHandler     e <- fromAddHandler addHandler     return (e,fire) @@ -377,7 +377,7 @@ mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b) mapEventIO f e1 = do     (e2, handler) <- newEvent-    reactimate $ (\a -> f a >>= handler) <$> e1+    reactimate $ (f >=> handler) <$> e1     return e2  {-----------------------------------------------------------------------------@@ -396,7 +396,7 @@         reactimate $ writeIORef output . Just <$> e2      actuate network-    bs <- forM xs $ \x -> do+    forM xs $ \x -> do         case x of             Nothing -> return Nothing             Just x  -> do@@ -404,7 +404,6 @@                 b <- readIORef output                 writeIORef output Nothing                 return b-    return bs  -- | Simple way to write a single event handler with -- functional reactive programming.

@@ -1,246 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-}-module Reactive.Banana.Internal.Combinators where--import           Control.Concurrent.MVar-import           Control.Event.Handler-import           Control.Monad-import           Control.Monad.Fix-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class           (lift)-import           Control.Monad.Trans.Reader-import           Data.Functor-import           Data.Functor.Identity-import           Data.IORef-import qualified Reactive.Banana.Prim        as Prim-import           Reactive.Banana.Prim.Cached-import           Data.These (These(..), these)--type Build   = Prim.Build-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 Moment     = ReaderT EventNetwork Prim.Build--liftBuild :: Build a -> Moment a-liftBuild = lift--{------------------------------------------------------------------------------    Interpretation-------------------------------------------------------------------------------}-interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined-    where-    g pulse = runCached =<< f (Prim.fromPure pulse)-    -- Ignore any  addHandler  inside the  Moment--{------------------------------------------------------------------------------    IO-------------------------------------------------------------------------------}--- | Data type representing an event network.-data EventNetwork = EventNetwork-    { runStep :: Prim.Step -> IO ()-    , actuate :: IO ()-    , pause   :: IO ()-    }---- | Compile to an event network.-compile :: Moment () -> IO EventNetwork-compile setup = do-    actuated <- newIORef False                   -- flag to set running status-    s        <- newEmptyMVar                     -- setup callback machinery-    let-        whenFlag flag action = readIORef flag >>= \b -> when b action-        runStep f            = whenFlag actuated $ do-            s1 <- takeMVar s                    -- read and take lock-            -- pollValues <- sequence polls     -- poll mutable data-            (output, s2) <- f s1                -- calculate new state-            putMVar s s2                        -- write state-            output                              -- run IO actions afterwards--        eventNetwork = EventNetwork-            { runStep = runStep-            , actuate = writeIORef actuated True-            , pause   = writeIORef actuated False-            }--    (output, s0) <-                             -- compile initial graph-        Prim.compile (runReaderT setup eventNetwork) Prim.emptyNetwork-    putMVar s s0                                -- set initial state--    return $ eventNetwork--fromAddHandler :: AddHandler a -> Moment (Event a)-fromAddHandler addHandler = do-    (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-    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-    a <- liftIO poll-    e <- liftBuild $ do-        p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP-        return $ Prim.fromPure p-    stepperB a e--liftIONow :: IO a -> Moment a-liftIONow = liftIO--liftIOLater :: IO () -> Moment ()-liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater--imposeChanges :: Behavior a -> Event () -> Behavior a-imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2)--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-never :: Event a-never = don'tCache  $ liftBuild $ Prim.neverP--mergeWith-  :: (a -> c)-  -> (b -> c)-  -> (a -> b -> c)-  -> Event a-  -> Event b-  -> Event c-mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y))---filterJust :: Event (Maybe a) -> Event a-filterJust  = liftCached1 $ liftBuild . Prim.filterJustP--mapE :: (a -> b) -> Event a -> Event b-mapE f = liftCached1 $ liftBuild . Prim.mapP f--applyE :: Behavior (a -> b) -> Event a -> Event b-applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px--changesB :: Behavior a -> Event (Future a)-changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px--pureB :: a -> Behavior a-pureB a = cache $ do-    p <- runCached never-    return (Prim.pureL a, p)--applyB :: Behavior (a -> b) -> Behavior a -> Behavior b-applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do-    p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2-    let l3 = Prim.applyL l1 l2-    return (l3,p3)--mapB :: (a -> b) -> Behavior a -> Behavior b-mapB f = applyB (pureB f)--{------------------------------------------------------------------------------    Combinators - accumulation-------------------------------------------------------------------------------}--- Make sure that the cached computation (Event or Behavior)--- is executed eventually during this moment.-trim :: Cached Moment a -> Moment (Cached Moment a)-trim b = do-    liftBuildFun Prim.buildLater $ void $ runCached b-    return b---- Cache a computation at this moment in time--- and make sure that it is performed in the Build monad eventually-cacheAndSchedule :: Moment a -> Moment (Cached Moment a)-cacheAndSchedule m = ask >>= \r -> liftBuild $ do-    let c = cache (const m r)   -- prevent let-floating!-    Prim.buildLater $ void $ runReaderT (runCached c) r-    return c--stepperB :: a -> Event a -> Moment (Behavior a)-stepperB a e = cacheAndSchedule $ do-    p0 <- runCached e-    liftBuild $ do-        p1    <- Prim.mapP const p0-        p2    <- Prim.mapP (const ()) p1-        (l,_) <- Prim.accumL a p1-        return (l,p2)--accumE :: a -> Event (a -> a) -> Moment (Event a)-accumE a e1 = cacheAndSchedule $ do-    p0 <- runCached e1-    liftBuild $ do-        (_,p1) <- Prim.accumL a p0-        return p1--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-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--executeP :: Pulse (Moment a) -> Moment (Pulse a)-executeP p1 = do-    r <- ask-    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-    -- Run cached computation later to allow more recursion with `Moment`-    p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e-    return $ fromPure p--switchE :: Event (Event a) -> Moment (Event a)-switchE e = ask >>= \r -> cacheAndSchedule $ do-    p1 <- runCached e-    liftBuild $ do-        p2 <- Prim.mapP (runReaderT . runCached) p1-        p3 <- Prim.executeP p2 r-        Prim.switchP p3--switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)-switchB b e = ask >>= \r -> cacheAndSchedule $ do-    ~(l0,p0) <- runCached b-    p1       <- runCached e-    liftBuild $ do-        p2 <- Prim.mapP (runReaderT . runCached) p1-        p3 <- Prim.executeP p2 r--        lr <- Prim.switchL l0 =<< Prim.mapP fst p3-        -- TODO: switch away the initial behavior-        let c1 = p0                              -- initial behavior changes-        c2 <- Prim.mapP (const ()) p3            -- or switch happens-        c3 <- Prim.switchP =<< Prim.mapP snd p3  -- or current behavior changes-        pr <- merge c1 =<< merge c2 c3-        return (lr, pr)--merge :: Pulse () -> Pulse () -> Build (Pulse ())-merge = Prim.mergeWithP Just Just (\_ _ -> Just ())

@@ -2,6 +2,8 @@     reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Reactive.Banana.Model (     -- * Synopsis     -- | Model implementation for learning and testing.@@ -27,6 +29,7 @@ import Control.Monad import Control.Monad.Fix import Data.These (These(..), these)+import Data.Maybe (fromMaybe)  {-$overview @@ -145,9 +148,7 @@ stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)     where     step i ~(x:xs) = i : step next xs-        where next = case x of-                        Just i  -> i-                        Nothing -> i+        where next = fromMaybe i x  -- Expressed using recursion and the other primitives -- FIXME: Strictness!@@ -166,9 +167,9 @@ observeE :: Event (Moment a) -> Event a observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE -switchE :: Event (Event a) -> Moment (Event a)-switchE es = M $ \t -> E $-    replicate t Nothing ++ switch (unE never) (forgetE t (forgetDiagonalE es))+switchE :: Event a -> Event (Event a) -> Moment (Event a)+switchE e es = M $ \t -> E $+    replicate t Nothing ++ switch (unE e) (forgetE t (forgetDiagonalE es))     where     switch (x:xs) (Nothing : ys) = x : switch xs ys     switch (x: _) (Just xs : ys) = x : switch (tail xs) ys

@@ -1,119 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim (-    -- * Synopsis-    -- | This is an internal module, useful if you want to-    -- implemented your own FRP library.-    -- If you just want to use FRP in your project,-    -- have a look at "Reactive.Banana" instead.--    -- * Evaluation-    Step, Network, emptyNetwork,--    -- * Build FRP networks-    Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,-    module Control.Monad.IO.Class,--    -- * Caching-    module Reactive.Banana.Prim.Cached,--    -- * Testing-    interpret, mapAccumM, mapAccumM_, runSpaceProfile,--    -- * IO-    newInput, addHandler, readLatch,--    -- * Pulse-    Pulse,-    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP,--    -- * Latch-    Latch,-    pureL, mapL, applyL, accumL, applyP,--    -- * 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, 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.---}

@@ -1,65 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Cached (-    -- | Utility for executing monadic actions once-    -- and then retrieving values from a cache.-    ---    -- Very useful for observable sharing.-    Cached, runCached, cache, fromPure, don'tCache,-    liftCached1, liftCached2,-    ) where--import Control.Monad-import Control.Monad.Fix-import Control.Monad.IO.Class-import Data.IORef-import System.IO.Unsafe       (unsafePerformIO)--{------------------------------------------------------------------------------    Cache type-------------------------------------------------------------------------------}-data Cached m a = Cached (m a)--runCached :: Cached m a -> m a-runCached (Cached x) = x---- | 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 :: (MonadFix m, MonadIO m) => m a -> Cached m a-cache m = unsafePerformIO $ do-    key <- liftIO $ newIORef Nothing-    return $ Cached $ do-        ma <- liftIO $ readIORef key    -- read the cached result-        case ma of-            Just a  -> return a         -- return the cached result.-            Nothing -> mdo-                liftIO $                -- write the result already-                    writeIORef key (Just a)-                a <- m                  -- evaluate-                return a---- | Return a pure value. Doesn't make use of the cache.-fromPure :: Monad m => a -> Cached m a-fromPure = Cached . return---- | Lift an action that is /not/ cached, for instance because it is idempotent.-don'tCache :: Monad m => m a -> Cached m a-don'tCache = Cached--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 :: (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-    b <- runCached cb-    f a b

@@ -1,150 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}-module Reactive.Banana.Prim.Combinators where--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class--import Reactive.Banana.Prim.Plumbing-    ( neverP, newPulse, newLatch, cachedLatch-    , dependOn, keepAlive, changeParent-    , getValueL-    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,-    )-import qualified Reactive.Banana.Prim.Plumbing (pureL)-import           Reactive.Banana.Prim.Types    (Latch, Future, Pulse, Build, EvalP)--import Debug.Trace--- debug s = trace s-debug s = id--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-mapP :: (a -> b) -> Pulse a -> Build (Pulse b)-mapP f p1 = do-    p2 <- newPulse "mapP" $ ({-# SCC mapP #-} fmap f <$> readPulseP p1)-    p2 `dependOn` p1-    return p2---- | Tag a 'Pulse' with future values of a 'Latch'.------ This is in contrast to 'applyP' which applies the current value--- of a 'Latch' to a pulse.-tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))-tagFuture x p1 = do-    p2 <- newPulse "tagFuture" $-        fmap . const <$> readLatchFutureP x <*> readPulseP p1-    p2 `dependOn` p1-    return p2--filterJustP :: Pulse (Maybe a) -> Build (Pulse a)-filterJustP p1 = do-    p2 <- newPulse "filterJustP" $ ({-# SCC filterJustP #-} join <$> readPulseP p1)-    p2 `dependOn` p1-    return p2--unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b)-unsafeMapIOP f p1 = do-        p2 <- newPulse "unsafeMapIOP" $-            ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1)-        p2 `dependOn` p1-        return p2-    where-    eval :: Maybe a -> EvalP (Maybe b)-    eval (Just x) = Just <$> liftIO (f x)-    eval Nothing  = return Nothing--mergeWithP-  :: (a -> Maybe c)-  -> (b -> Maybe c)-  -> (a -> b -> Maybe c)-  -> Pulse a-  -> Pulse b-  -> Build (Pulse c)-mergeWithP f g h px py = do-  p <- newPulse "mergeWithP" $-       ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py)-  p `dependOn` px-  p `dependOn` py-  return p-  where-    eval Nothing  Nothing  = Nothing-    eval (Just x) Nothing  = f x-    eval Nothing  (Just y) = g y-    eval (Just x) (Just y) = h x y---- See note [LatchRecursion]-applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)-applyP f x = do-    p <- newPulse "applyP" $-        ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x)-    p `dependOn` x-    return p--pureL :: a -> Latch 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 #-} f <$> getValueL lx)--applyL :: Latch (a -> b) -> Latch a -> Latch b-applyL lf lx = cachedLatch $-    ({-# SCC applyL #-} getValueL lf <*> getValueL lx)--accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)-accumL a p1 = do-    (updateOn, x) <- newLatch a-    p2 <- applyP (mapL (\x f -> f x) x) p1-    updateOn p2-    return (x,p2)---- specialization of accumL-stepperL :: a -> Pulse a -> Build (Latch a)-stepperL a p = do-    (updateOn, x) <- newLatch a-    updateOn p-    return x--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)-switchL l pl = mdo-    x <- stepperL l pl-    return $ cachedLatch $ getValueL x >>= getValueL--executeP :: forall a b. 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 :: Maybe (b -> Build a) -> EvalP (Maybe a)-    eval (Just x) = Just <$> liftBuildP (x b)-    eval Nothing  = return Nothing--switchP :: Pulse (Pulse a) -> Build (Pulse a)-switchP pp = mdo-    never <- neverP-    lp    <- stepperL never pp-    let-        -- switch to a new parent-        switch = do-            mnew <- readPulseP pp-            case mnew of-                Nothing  -> return ()-                Just new -> liftBuildP $ p2 `changeParent` new-            return Nothing-        -- fetch value from old parent-        eval = readPulseP =<< readLatchP lp--    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())-    p1 `dependOn` pp-    p2 <- newPulse "switchP_out" eval-    p2 `keepAlive` p1-    return p2

@@ -1,110 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}-module Reactive.Banana.Prim.Compile where--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--{------------------------------------------------------------------------------   Compilation-------------------------------------------------------------------------------}--- | Change a 'Network' of pulses and latches by--- executing a 'BuildIO' action.-compile :: BuildIO a -> Network -> IO (a, Network)-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 = OB.inserts outputs1 os-            , nAlwaysP = Just theAlwaysP-            }-    return (a,state2)--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}--- | Simple interpreter for pulse/latch networks.------ Mainly useful for testing functionality------ Note: The result is not computed lazily, for similar reasons--- 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-    o   <- newIORef Nothing-    let network = do-            (pin, sin) <- liftBuild $ newInput-            pmid       <- f pin-            pout       <- liftBuild $ mapP return pmid-            liftBuild $ addHandler pout (writeIORef o . Just)-            return sin--    -- compile initial network-    (sin, state) <- compile network emptyNetwork--    let go Nothing  s1 = return (Nothing,s1)-        go (Just a) s1 = do-            (reactimate,s2) <- sin a s1-            reactimate              -- write output-            ma <- readIORef o       -- read output-            writeIORef o Nothing-            return (ma,s2)--    mapAccumM go state xs         -- run several steps---- | 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 :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()-runSpaceProfile f xs = do-    let g = do-        (p1, fire) <- liftBuild $ newInput-        p2 <- f p1-        p3 <- mapP return p2                -- wrap into Future-        addHandler p3 (\b -> void $ evaluate b)-        return fire-    (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---- | 'mapAccum' for a monad.-mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]-mapAccumM _ _  []     = return []-mapAccumM f s0 (x:xs) = do-    (b,s1) <- f x s0-    bs     <- mapAccumM f s1 xs-    return (b:bs)---- | 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-    (_,s1) <- f x s0-    mapAccumM_ f s1 xs

@@ -1,108 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}-module Reactive.Banana.Prim.Dependencies (-    -- | Utilities for operating on node dependencies.-    addChild, changeParent, buildDependencies,-    ) where--import Control.Monad-import Data.Functor-import Data.Monoid-import System.Mem.Weak--import qualified Reactive.Banana.Prim.Graph as Graph-import           Reactive.Banana.Prim.Types-import           Reactive.Banana.Prim.Util--{------------------------------------------------------------------------------    Accumulate dependency information for nodes-------------------------------------------------------------------------------}--- | Add a new child node to a parent node.-addChild :: SomeNode -> SomeNode -> DependencyBuilder-addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty)---- | 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)])---- | 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-    gr :: Graph.Graph SomeNode-    gr = f Graph.emptyGraph--{------------------------------------------------------------------------------    Set dependencies of individual notes-------------------------------------------------------------------------------}--- | 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---- | 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---- | 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 = []}---- | 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:)--    -- 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--    -- 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)--{------------------------------------------------------------------------------    Helper functions-------------------------------------------------------------------------------}-getChildren :: SomeNode -> IO [SomeNode]-getChildren (P p) = deRefWeaks =<< fmap _childrenP (readRef p)-getChildren _     = return []--getParents :: SomeNode -> IO [SomeNode]-getParents (P p) = deRefWeaks =<< fmap _parentsP (readRef p)-getParents _     = return []

@@ -1,124 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, BangPatterns #-}-module Reactive.Banana.Prim.Evaluation (-    step-    ) where--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.OrderedBag as OB-import           Reactive.Banana.Prim.Plumbing-import           Reactive.Banana.Prim.Types-import           Reactive.Banana.Prim.Util--type Queue = Q.MinPQueue Level--{------------------------------------------------------------------------------    Evaluation step-------------------------------------------------------------------------------}--- | Evaluate all the pulses in the graph,--- Rebuild the graph as necessary and update the latch values.-step :: Inputs -> Step-step (inputs,pulses)-        Network{ nTime = time1-        , nOutputs = outputs1-        , nAlwaysP = Just alwaysP   -- we assume that this has been built already-        }-    = {-# SCC step #-} do--    -- 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 :: [(Output, EvalO)]-        actions = OB.inOrder outputs outputs1   -- EvalO actions in proper order--        state2 :: Network-        state2  = Network-            { nTime    = next time1-            , nOutputs = OB.inserts outputs1 os-            , nAlwaysP = Just alwaysP-            }-    return (runEvalOs $ map snd actions, state2)--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 :: [SomeNode] -> EvalP ()-evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty-    where-    go :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> Queue SomeNode -> IO ()-    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-insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go-    where-    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-    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

@@ -1,102 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Implementation of graph-related functionality-------------------------------------------------------------------------------}-{-# language ScopedTypeVariables#-}--module Reactive.Banana.Prim.Graph-  ( Graph-  , emptyGraph-  , insertEdge-  , getChildren-  , listParents-  , dfs-  ) 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-    { -- | The mapping from each node to the set of nodes reachable by an out-edge. If a node has no out-edges, it is-      -- not a member of this map.-      ---      -- Invariant: the values are non-empty lists.-      children :: Map.HashMap a [a]-      -- | The Mapping from each node to the set of nodes reachable by an in-edge. If a node has no in-edges, it is not-      -- a member of this map.-      ---      -- Invariant: the values are non-empty lists.-    , parents  :: Map.HashMap a [a]-      -- | The set of nodes.-      ---      -- Invariant: equals (key children `union` keys parents)-    , 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 (\new old -> new ++ old) x [y] (children gr)-    , parents  = Map.insertWith (\new old -> new ++ old) 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 :: forall a. (Eq a, Hashable a) => Graph a -> [a]-listParents gr = list-    where-    -- all nodes without parents-    ancestors :: [a]-    -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges.-    ancestors    = [x | x <- Map.keys (children gr), not (hasParents x)]-    hasParents x = Map.member x (parents gr)-    -- all nodes in topological order "parents before children"-    list :: [a]-    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' :: forall a m. (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]-dfs' xs succs = liftM fst $ go xs [] Set.empty-    where-    go :: [a] -> [a] -> Set.HashSet a -> m ([a], Set.HashSet a)-    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'

@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+module Reactive.Banana.Prim.High.Cached (+    -- | Utility for executing monadic actions once+    -- and then retrieving values from a cache.+    --+    -- Very useful for observable sharing.+    Cached, runCached, cache, fromPure, don'tCache,+    liftCached1, liftCached2,+    ) where++import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.IORef+import System.IO.Unsafe       (unsafePerformIO)++{-----------------------------------------------------------------------------+    Cache type+------------------------------------------------------------------------------}+data Cached m a = Cached (m a)++runCached :: Cached m a -> m a+runCached (Cached x) = x++-- | 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 :: (MonadFix m, MonadIO m) => m a -> Cached m a+cache m = unsafePerformIO $ do+    key <- liftIO $ newIORef Nothing+    return $ Cached $ do+        ma <- liftIO $ readIORef key    -- read the cached result+        case ma of+            Just a  -> return a         -- return the cached result.+            Nothing -> mdo+                liftIO $                -- write the result already+                    writeIORef key (Just a)+                a <- m                  -- evaluate+                return a++-- | Return a pure value. Doesn't make use of the cache.+fromPure :: Monad m => a -> Cached m a+fromPure = Cached . return++-- | Lift an action that is /not/ cached, for instance because it is idempotent.+don'tCache :: Monad m => m a -> Cached m a+don'tCache = Cached++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 :: (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+    b <- runCached cb+    f a b

@@ -0,0 +1,250 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE FlexibleInstances, NamedFieldPuns, NoMonomorphismRestriction #-}+module Reactive.Banana.Prim.High.Combinators where++import           Control.Concurrent.MVar+import           Control.Event.Handler+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class           (lift)+import           Control.Monad.Trans.Reader+import           Data.IORef+import qualified Reactive.Banana.Prim.Mid        as Prim+import           Reactive.Banana.Prim.High.Cached++type Build   = Prim.Build+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 Moment     = ReaderT EventNetwork Prim.Build++liftBuild :: Build a -> Moment a+liftBuild = lift++{-----------------------------------------------------------------------------+    Interpretation+------------------------------------------------------------------------------}+interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined+    where+    g pulse = runCached =<< f (Prim.fromPure pulse)+    -- Ignore any  addHandler  inside the  Moment++{-----------------------------------------------------------------------------+    IO+------------------------------------------------------------------------------}+-- | Data type representing an event network.+data EventNetwork = EventNetwork+    { actuated :: IORef Bool+    , s :: MVar Prim.Network+    }+++runStep :: EventNetwork -> Prim.Step -> IO ()+runStep EventNetwork{ actuated, s } f = whenFlag actuated $ do+    s1 <- takeMVar s                    -- read and take lock+    -- pollValues <- sequence polls     -- poll mutable data+    (output, s2) <- f s1                -- calculate new state+    putMVar s s2                        -- write state+    output                              -- run IO actions afterwards+  where+    whenFlag flag action = readIORef flag >>= \b -> when b action+++actuate :: EventNetwork -> IO ()+actuate EventNetwork{ actuated } = writeIORef actuated True++pause :: EventNetwork -> IO ()+pause EventNetwork{ actuated } = writeIORef actuated False++-- | Compile to an event network.+compile :: Moment () -> IO EventNetwork+compile setup = do+    actuated <- newIORef False                   -- flag to set running status+    s        <- newEmptyMVar                     -- setup callback machinery++    let eventNetwork = EventNetwork{ actuated, s }++    (_output, s0) <-                             -- compile initial graph+        Prim.compile (runReaderT setup eventNetwork) =<< Prim.emptyNetwork+    putMVar s s0                                -- set initial state++    return eventNetwork++fromAddHandler :: AddHandler a -> Moment (Event a)+fromAddHandler addHandler = do+    (p, fire) <- liftBuild Prim.newInput+    network   <- ask+    _unregister <- liftIO $ register addHandler $ runStep network . fire+    return $ Prim.fromPure p++addReactimate :: Event (Future (IO ())) -> Moment ()+addReactimate e = do+    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+    a <- liftIO poll+    e <- liftBuild $ do+        p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP+        return $ Prim.fromPure p+    stepperB a e++liftIONow :: IO a -> Moment a+liftIONow = liftIO++liftIOLater :: IO () -> Moment ()+liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater++imposeChanges :: Behavior a -> Event () -> Behavior a+imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2)++{-----------------------------------------------------------------------------+    Combinators - basic+------------------------------------------------------------------------------}+never :: Event a+never = don'tCache  $ liftBuild Prim.neverP++mergeWith+  :: (a -> c)+  -> (b -> c)+  -> (a -> b -> c)+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y))+++filterJust :: Event (Maybe a) -> Event a+filterJust  = liftCached1 $ liftBuild . Prim.filterJustP++mapE :: (a -> b) -> Event a -> Event b+mapE f = liftCached1 $ liftBuild . Prim.mapP f++applyE :: Behavior (a -> b) -> Event a -> Event b+applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px++changesB :: Behavior a -> Event (Future a)+changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px++pureB :: a -> Behavior a+pureB a = cache $ do+    p <- runCached never+    return (Prim.pureL a, p)++applyB :: Behavior (a -> b) -> Behavior a -> Behavior b+applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do+    p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2+    let l3 = Prim.applyL l1 l2+    return (l3,p3)++mapB :: (a -> b) -> Behavior a -> Behavior b+mapB f = applyB (pureB f)++{-----------------------------------------------------------------------------+    Combinators - accumulation+------------------------------------------------------------------------------}+-- Make sure that the cached computation (Event or Behavior)+-- is executed eventually during this moment.+trim :: Cached Moment a -> Moment (Cached Moment a)+trim b = do+    liftBuildFun Prim.buildLater $ void $ runCached b+    return b++-- Cache a computation at this moment in time+-- and make sure that it is performed in the Build monad eventually+cacheAndSchedule :: Moment a -> Moment (Cached Moment a)+cacheAndSchedule m = ask >>= \r -> liftBuild $ do+    let c = cache (const m r)   -- prevent let-floating!+    Prim.buildLater $ void $ runReaderT (runCached c) r+    return c++stepperB :: a -> Event a -> Moment (Behavior a)+stepperB a e = cacheAndSchedule $ do+    p0 <- runCached e+    liftBuild $ do+        p1    <- Prim.mapP const p0+        p2    <- Prim.mapP (const ()) p1+        (l,_) <- Prim.accumL a p1+        return (l,p2)++accumE :: a -> Event (a -> a) -> Moment (Event a)+accumE a e1 = cacheAndSchedule $ do+    p0 <- runCached e1+    liftBuild $ do+        (_,p1) <- Prim.accumL a p0+        return p1++{-----------------------------------------------------------------------------+    Combinators - dynamic event switching+------------------------------------------------------------------------------}+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++executeP :: Pulse (Moment a) -> Moment (Pulse a)+executeP p1 = do+    r <- ask+    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+    -- Run cached computation later to allow more recursion with `Moment`+    p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e+    return $ fromPure p++switchE :: Event a -> Event (Event a) -> Moment (Event a)+switchE e0 e = ask >>= \r -> cacheAndSchedule $ do+    p0 <- runCached e0+    p1 <- runCached e+    liftBuild $ do+        p2 <- Prim.mapP (runReaderT . runCached) p1++        p3 <- Prim.executeP p2 r+        Prim.switchP p0 p3++switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB b e = ask >>= \r -> cacheAndSchedule $ do+    ~(l0,p0) <- runCached b+    p1       <- runCached e+    liftBuild $ do+        p2 <- Prim.mapP (runReaderT . runCached) p1+        p3 <- Prim.executeP p2 r++        lr <- Prim.switchL l0 =<< Prim.mapP fst p3+        -- TODO: switch away the initial behavior+        let c1 = p0                              -- initial behavior changes+        c2 <- Prim.mapP (const ()) p3            -- or switch happens+        never <- Prim.neverP+        c3 <- Prim.switchP never =<< Prim.mapP snd p3  -- or current behavior changes+        pr <- merge c1 =<< merge c2 c3+        return (lr, pr)++merge :: Pulse () -> Pulse () -> Build (Pulse ())+merge = Prim.mergeWithP Just Just (\_ _ -> Just ())

@@ -1,56 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Reactive.Banana.Prim.IO where--import           Control.Monad.IO.Class-import           Data.Functor-import           Data.IORef-import qualified Data.Vault.Lazy        as Lazy--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--{------------------------------------------------------------------------------    Primitives connecting to the outside world-------------------------------------------------------------------------------}--- | Create a new pulse in the network and a function to trigger it.------ Together with 'addHandler', this function can be used to operate with--- pulses as with standard callback-based events.-newInput :: forall a. 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-        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.------ The pulse may refer to future latch values.-addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build ()-addHandler p1 f = do-    p2 <- mapP (fmap f) p1-    addOutput p2---- | Read the value of a 'Latch' at a particular moment in time.-readLatch :: Latch a -> Build a-readLatch = readLatchB

@@ -0,0 +1,110 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+module Reactive.Banana.Prim.Low.Compile where++import Control.Exception (evaluate)+import Data.Functor+import Data.IORef++import           Reactive.Banana.Prim.Mid.Combinators (mapP)+import           Reactive.Banana.Prim.Low.IO+import qualified Reactive.Banana.Prim.Low.OrderedBag  as OB+import           Reactive.Banana.Prim.Low.Plumbing+import           Reactive.Banana.Prim.Low.Types++{-----------------------------------------------------------------------------+   Compilation+------------------------------------------------------------------------------}+-- | Change a 'Network' of pulses and latches by+-- executing a 'BuildIO' action.+compile :: BuildIO a -> Network -> IO (a, Network)+compile m Network{nTime, nOutputs, nAlwaysP} = do+    (a, topology, os) <- runBuildIO (nTime, nAlwaysP) m+    doit topology++    let state2 = Network+            { nTime    = next nTime+            , nOutputs = OB.inserts nOutputs os+            , nAlwaysP+            }+    return (a,state2)++emptyNetwork :: IO Network+emptyNetwork = do+  (alwaysP, _, _) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())+  pure Network+    { nTime    = next beginning+    , nOutputs = OB.empty+    , nAlwaysP = alwaysP+    }++{-----------------------------------------------------------------------------+    Testing+------------------------------------------------------------------------------}+-- | Simple interpreter for pulse/latch networks.+--+-- Mainly useful for testing functionality+--+-- Note: The result is not computed lazily, for similar reasons+-- 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+    o   <- newIORef Nothing+    let network = do+            (pin, sin) <- liftBuild newInput+            pmid       <- f pin+            pout       <- liftBuild $ mapP return pmid+            liftBuild $ addHandler pout (writeIORef o . Just)+            return sin++    -- compile initial network+    (sin, state) <- compile network =<< emptyNetwork++    let go Nothing  s1 = return (Nothing,s1)+        go (Just a) s1 = do+            (reactimate,s2) <- sin a s1+            reactimate              -- write output+            ma <- readIORef o       -- read output+            writeIORef o Nothing+            return (ma,s2)++    mapAccumM go state xs         -- run several steps++-- | 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 :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()+runSpaceProfile f xs = do+    let g = do+        (p1, fire) <- liftBuild newInput+        p2 <- f p1+        p3 <- mapP return p2                -- wrap into Future+        addHandler p3 (void . evaluate)+        return fire+    (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++-- | 'mapAccum' for a monad.+mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]+mapAccumM _ _  []     = return []+mapAccumM f s0 (x:xs) = do+    (b,s1) <- f x s0+    bs     <- mapAccumM f s1 xs+    return (b:bs)++-- | 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+    (_,s1) <- f x s0+    mapAccumM_ f s1 xs

@@ -0,0 +1,108 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module Reactive.Banana.Prim.Low.Dependencies (+    -- | Utilities for operating on node dependencies.+    addChild, changeParent, buildDependencies,+    ) where++import           Control.Monad+import           Data.Monoid+import           System.Mem.Weak++import qualified Reactive.Banana.Prim.Low.Graph as Graph+import           Reactive.Banana.Prim.Low.Types+import           Reactive.Banana.Prim.Low.Util++{-----------------------------------------------------------------------------+    Accumulate dependency information for nodes+------------------------------------------------------------------------------}+-- | Add a new child node to a parent node.+addChild :: SomeNode -> SomeNode -> DependencyBuilder+addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty)++-- | 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)])++-- | 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+    gr :: Graph.Graph SomeNode+    gr = f Graph.emptyGraph++{-----------------------------------------------------------------------------+    Set dependencies of individual notes+------------------------------------------------------------------------------}+-- | 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++-- | 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+doAddChild (L _) _ = error "doAddChild: Cannot add children to LatchWrite"+doAddChild (O _) _ = error "doAddChild: Cannot add children to Output"++-- | 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 = []}++-- | 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:)++    -- 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++    -- lower all parents of the node if the parent was higher than the node+    when (d > 0) $ do+        parents <- Graph.reversePostOrder (P parent) getParents+        forM_ parents $ \case+            P node -> modify' node $ update levelP (subtract d)+            L _    -> error "doChangeParent: Cannot change parent of LatchWrite"+            O _    -> error "doChangeParent: Cannot change parent of Output"++{-----------------------------------------------------------------------------+    Helper functions+------------------------------------------------------------------------------}+getParents :: SomeNode -> IO [SomeNode]+getParents (P p) = deRefWeaks . _parentsP =<< readRef p+getParents _     = return []

@@ -0,0 +1,119 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecordWildCards #-}+module Reactive.Banana.Prim.Low.Evaluation (+    step+    ) where++import Control.Monad ( join )+import           Control.Monad.IO.Class+import qualified Control.Monad.Trans.RWSIO          as RWS+import qualified Data.PQueue.Prio.Min               as Q+import qualified Data.Vault.Lazy                    as Lazy+import           System.Mem.Weak++import qualified Reactive.Banana.Prim.Low.OrderedBag as OB+import           Reactive.Banana.Prim.Low.Plumbing+import           Reactive.Banana.Prim.Low.Types+import           Reactive.Banana.Prim.Low.Util++type Queue = Q.MinPQueue Level++{-----------------------------------------------------------------------------+    Evaluation step+------------------------------------------------------------------------------}+-- | Evaluate all the pulses in the graph,+-- Rebuild the graph as necessary and update the latch values.+step :: Inputs -> Step+step (inputs,pulses)+        Network{ nTime = time1+        , nOutputs = outputs1+        , nAlwaysP = alwaysP+        }+    = do++    -- 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 :: [(Output, EvalO)]+        actions = OB.inOrder outputs outputs1   -- EvalO actions in proper order++        state2 :: Network+        state2  = Network+            { nTime    = next time1+            , nOutputs = OB.inserts outputs1 os+            , nAlwaysP = alwaysP+            }+    return (runEvalOs $ map snd actions, state2)++runEvalOs :: [EvalO] -> IO ()+runEvalOs = mapM_ join++{-----------------------------------------------------------------------------+    Traversal in dependency order+------------------------------------------------------------------------------}+-- | Update all pulses in the graph, starting from a given set of nodes+evaluatePulses :: [SomeNode] -> EvalP ()+evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty+    where+    go :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> Queue SomeNode -> IO ()+    go r q =+        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+insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)+insertNodes (RWS.Tuple (time,_) _ _) = go+    where+    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)+    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,102 @@+{-----------------------------------------------------------------------------+    reactive-banana++    Implementation of graph-related functionality+------------------------------------------------------------------------------}+{-# language ScopedTypeVariables#-}++module Reactive.Banana.Prim.Low.Graph+  ( Graph+  , emptyGraph+  , insertEdge+  , getChildren+  , getParents+  , listParents+  , reversePostOrder+  ) where++import           Data.Functor.Identity+import           Data.Hashable+import qualified Data.HashMap.Strict   as Map+import qualified Data.HashSet          as Set+import           Data.Maybe++{-----------------------------------------------------------------------------+    Graphs and topological sorting+------------------------------------------------------------------------------}+data Graph a = Graph+    { -- | The mapping from each node to the set of nodes reachable by an out-edge. If a node has no out-edges, it is+      -- not a member of this map.+      --+      -- Invariant: the values are non-empty lists.+      children :: Map.HashMap a [a]+      -- | The Mapping from each node to the set of nodes reachable by an in-edge. If a node has no in-edges, it is not+      -- a member of this map.+      --+      -- Invariant: the values are non-empty lists.+    , parents  :: Map.HashMap a [a]+      -- | The set of nodes.+      --+      -- Invariant: equals (key children `union` keys parents)+    , 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 (\new old -> new ++ old) x [y] (children gr)+    , parents  = Map.insertWith (\new old -> new ++ old) 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 = fromMaybe [] . 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 = fromMaybe [] . Map.lookup x . parents $ gr++-- | List all nodes such that each parent is listed before all of its children.+listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a]+listParents gr = list+    where+    -- all nodes without parents+    ancestors :: [a]+    -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges.+    ancestors    = [x | x <- Map.keys (children gr), not (hasParents x)]+    hasParents x = Map.member x (parents gr)+    -- all nodes in topological order "parents before children"+    list = runIdentity $ reversePostOrder' ancestors (Identity . getChildren gr)++{-----------------------------------------------------------------------------+    Graph traversal+------------------------------------------------------------------------------}+-- | Graph represented as map of immediate children.+type GraphM m a = a -> m [a]++-- | Computes the reverse post-order,+-- listing all transitive children of a node.+-- Each node is listed *before* all its children have been listed.+reversePostOrder :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]+reversePostOrder x = reversePostOrder' [x]++-- | Reverse post-order from multiple nodes.+-- INVARIANT: For this to be a valid topological order,+-- none of the nodes may have a parent.+reversePostOrder' :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]+reversePostOrder' xs children = fst <$> go xs [] Set.empty+    where+    go []     rpo visited        = return (rpo, visited)+    go (x:xs) rpo visited+        | x `Set.member` visited = go xs rpo visited+        | otherwise              = do+            xs' <- children x+            -- visit all children+            (rpo', visited') <- go xs' rpo (Set.insert x visited)+            -- prepend this node as all children have been visited+            go xs (x:rpo') visited'

@@ -0,0 +1,55 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Reactive.Banana.Prim.Low.IO where++import           Control.Monad.IO.Class+import qualified Data.Vault.Lazy        as Lazy++import Reactive.Banana.Prim.Mid.Combinators (mapP)+import Reactive.Banana.Prim.Low.Evaluation  (step)+import Reactive.Banana.Prim.Low.Plumbing+import Reactive.Banana.Prim.Low.Types+import Reactive.Banana.Prim.Low.Util++debug :: String -> a -> a+debug _ = id++{-----------------------------------------------------------------------------+    Primitives connecting to the outside world+------------------------------------------------------------------------------}+-- | Create a new pulse in the network and a function to trigger it.+--+-- Together with 'addHandler', this function can be used to operate with+-- pulses as with standard callback-based events.+newInput :: forall a. 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+        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.+--+-- The pulse may refer to future latch values.+addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build ()+addHandler p1 f = do+    p2 <- mapP (fmap f) p1+    addOutput p2++-- | Read the value of a 'Latch' at a particular moment in time.+readLatch :: Latch a -> Build a+readLatch = readLatchB

@@ -0,0 +1,42 @@+{-----------------------------------------------------------------------------+    reactive-banana++    Implementation of a bag whose elements are ordered by arrival time.+------------------------------------------------------------------------------}+{-# LANGUAGE TupleSections #-}+module Reactive.Banana.Prim.Low.OrderedBag where++import qualified Data.HashMap.Strict as Map+import           Data.Hashable+import           Data.List ( foldl', sortBy )+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) => OrderedBag a -> a -> OrderedBag a+insert (OB xs n) x = OB (Map.insertWith (\_new old -> old) x n xs) (n+1)++-- | Add a sequence of elements to an ordered bag.+--+-- The ordering is left-to-right. For example, the head of the sequence+-- comes after all elements in the bag,+-- but before the other elements in the sequence.+inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a+inserts = foldl' insert++-- | 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

@@ -0,0 +1,250 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecordWildCards, RecursiveDo, ScopedTypeVariables #-}+module Reactive.Banana.Prim.Low.Plumbing where++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.IORef+import qualified Data.Vault.Lazy                    as Lazy+import           System.IO.Unsafe++import qualified Reactive.Banana.Prim.Low.Dependencies as Deps+import           Reactive.Banana.Prim.Low.Types+import           Reactive.Banana.Prim.Low.Util+import Data.Maybe (fromMaybe)++{-----------------------------------------------------------------------------+    Build primitive pulses and latches+------------------------------------------------------------------------------}+-- | Make 'Pulse' from evaluation function+newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)+newPulse name eval = liftIO $ do+    key <- Lazy.newKey+    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 = liftIO $ do+    key <- Lazy.newKey+    newRef $ Pulse+        { _keyP      = key+        , _seenP     = agesAgo+        , _evalP     = return Nothing+        , _childrenP = []+        , _parentsP  = []+        , _levelP    = ground+        , _nameP     = "neverP"+        }++-- | 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 :: forall a. a -> Build (Pulse a -> Build (), Latch a)+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 :: Pulse a -> Build ()+        updateOn p = do+            w  <- liftIO $ mkWeakRefValue latch latch+            lw <- liftIO $ newRef $ LatchWrite+                { _evalLW  = fromMaybe err <$> readPulseP p+                , _latchLW = w+                }+            -- 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 :: 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 = do+    o <- liftIO $ newRef $ Output+        { _evalO = fromMaybe (return $ debug "nop") <$> readPulseP p+        }+    P p `addChild` O o+    RW.tell $ BuildW (mempty, [o], mempty, mempty)++{-----------------------------------------------------------------------------+    Build monad+------------------------------------------------------------------------------}+runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])+runBuildIO i m = 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'')++buildLater :: Build () -> Build ()+buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)++-- | 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 = fst <$> RW.ask++alwaysP :: Build (Pulse ())+alwaysP = snd <$> RW.ask++readLatchB :: Latch a -> Build a+readLatchB = liftIO . readLatchIO++dependOn :: Pulse child -> Pulse parent -> Build ()+dependOn child parent = P parent `addChild` P child++keepAlive :: Pulse child -> Pulse parent -> Build ()+keepAlive child parent = liftIO $ void $ mkWeakRefValue child parent++addChild :: SomeNode -> SomeNode -> Build ()+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 = RW.tell $ BuildW (mempty, mempty, Action x, mempty)++{-----------------------------------------------------------------------------+    EvalL monad+------------------------------------------------------------------------------}+-- | 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 ()++getValueL :: Latch a -> EvalL a+getValueL latch = do+    Latch{..} <- readRef latch+    _evalL++{-----------------------------------------------------------------------------+    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)++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 p = do+    Pulse{..} <- readRef p+    join . Lazy.lookup _keyP <$> RWS.get++writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()+writePulseP key a = do+    s <- RWS.get+    RWS.put $ Lazy.insert key a s++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 :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a+unwrapEvalP r m = RWS.run m r++wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a+wrapEvalP m = RWS.R m

@@ -0,0 +1,227 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+module Reactive.Banana.Prim.Low.Types where++import           Control.Monad.Trans.RWSIO+import           Control.Monad.Trans.ReaderWriterIO+import           Data.Hashable+import           Data.Semigroup+import qualified Data.Vault.Lazy                    as Lazy+import           System.IO.Unsafe+import           System.Mem.Weak++import Reactive.Banana.Prim.Low.Graph            (Graph)+import Reactive.Banana.Prim.Low.OrderedBag as OB (OrderedBag)+import Reactive.Banana.Prim.Low.Util++{-----------------------------------------------------------------------------+    Network+------------------------------------------------------------------------------}+-- | A 'Network' represents the state of a pulse/latch network,+data Network = Network+    { nTime           :: !Time                 -- Current time.+    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.+    , nAlwaysP        :: !(Pulse ())   -- Pulse that always fires.+    }++type Inputs        = ([SomeNode], Lazy.Vault)+type EvalNetwork a = Network -> IO (a, Network)+type Step          = EvalNetwork (IO ())++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+    --          )++instance Semigroup BuildW where+    BuildW x <> BuildW y = BuildW (x <> y)++instance Monoid BuildW where+    mempty  = BuildW mempty+    mappend = (<>)++type BuildIO = Build++type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)])++{-----------------------------------------------------------------------------+    Synonyms+------------------------------------------------------------------------------}+-- | Priority used to determine evaluation order for pulses.+type Level = Int++ground :: Level+ground = 0++-- | 'IO' actions as a monoid with respect to sequencing.+newtype Action = Action { doit :: IO () }+instance Semigroup Action where+    Action x <> Action y = Action (x >> y)+instance Monoid Action where+    mempty = Action $ return ()+    mappend = (<>)++-- | Lens-like functionality.+data Lens s a = Lens (s -> a) (a -> s -> s)++set :: Lens s a -> a -> s -> s+set (Lens _   set)   = set++update :: Lens s a -> (a -> a) -> s -> s+update (Lens get set) f = \s -> set (f $ get s) s++{-----------------------------------------------------------------------------+    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.+    }++instance Show (Pulse a) where+    show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p)++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.+    }++type Output  = Ref Output'+data Output' = Output+    { _evalO     :: EvalP EvalO+    }++data SomeNode+    = forall a. P (Pulse a)+    | L LatchWrite+    | O Output++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) = equalRef x y+    (L x) == (L y) = equalRef x y+    (O x) == (O y) = equalRef x y+    _     == _     = False++{-# INLINE mkWeakNodeValue #-}+mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)+mkWeakNodeValue (P x) = mkWeakRefValue x+mkWeakNodeValue (L x) = mkWeakRefValue x+mkWeakNodeValue (O x) = mkWeakRefValue x++-- Lenses for various parameters+seenP :: Lens (Pulse' a) Time+seenP = Lens _seenP  (\a s -> s { _seenP = a })++seenL :: Lens (Latch' a) Time+seenL = Lens _seenL  (\a s -> s { _seenL = a })++valueL :: Lens (Latch' a) a+valueL = Lens _valueL (\a s -> s { _valueL = a })++parentsP :: Lens (Pulse' a) [Weak SomeNode]+parentsP = Lens _parentsP (\a s -> s { _parentsP = a })++childrenP :: Lens (Pulse' a) [Weak SomeNode]+childrenP = Lens _childrenP (\a s -> s { _childrenP = a })++levelP :: Lens (Pulse' a) Int+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+------------------------------------------------------------------------------}+printNode :: SomeNode -> IO String+printNode (P p) = _nameP <$> readRef p+printNode (L _) = return "L"+printNode (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 Semigroup Time where+    T x <> T y = T (max x y)++instance Monoid Time where+    mappend = (<>)+    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,63 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE MagicHash, UnboxedTuples #-}+module Reactive.Banana.Prim.Low.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 Eq (Ref a) where (==) = equalRef++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+------------------------------------------------------------------------------}+mkWeakIORefValue :: IORef a -> value -> IO (Weak value)+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) val = GHC.IO $ \s ->+  case GHC.mkWeakNoFinalizer# r# val s of (# s1, w #) -> (# s1, GHC.Weak w #)++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 = catMaybes <$> mapM deRefWeak ws

@@ -0,0 +1,113 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid (+    -- * Synopsis+    -- | This is an internal module, useful if you want to+    -- implemented your own FRP library.+    -- If you just want to use FRP in your project,+    -- have a look at "Reactive.Banana" instead.++    -- * Evaluation+    Step, Network, emptyNetwork,++    -- * Build FRP networks+    Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,+    module Control.Monad.IO.Class,++    -- * Caching+    module Reactive.Banana.Prim.High.Cached,++    -- * Testing+    interpret, mapAccumM, mapAccumM_, runSpaceProfile,++    -- * IO+    newInput, addHandler, readLatch,++    -- * Pulse+    Pulse,+    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP,++    -- * Latch+    Latch,+    pureL, mapL, applyL, accumL, applyP,++    -- * Dynamic event switching+    switchL, executeP, switchP++    -- * Notes+    -- $recursion+  ) where+++import Control.Monad.IO.Class+import Reactive.Banana.Prim.Low.Compile+import Reactive.Banana.Prim.Low.IO+import Reactive.Banana.Prim.Low.Plumbing+    ( neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater )+import Reactive.Banana.Prim.Low.Types+import Reactive.Banana.Prim.Mid.Combinators+import Reactive.Banana.Prim.High.Cached++{-----------------------------------------------------------------------------+    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.++-}++-- 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.++-}

@@ -0,0 +1,149 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+module Reactive.Banana.Prim.Mid.Combinators where++import Control.Monad+import Control.Monad.IO.Class++import Reactive.Banana.Prim.Low.Plumbing+    ( newPulse, newLatch, cachedLatch+    , dependOn, keepAlive, changeParent+    , getValueL+    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,+    )+import qualified Reactive.Banana.Prim.Low.Plumbing (pureL)+import           Reactive.Banana.Prim.Low.Types    (Latch, Future, Pulse, Build, EvalP)++debug :: String -> a -> a+-- debug s = trace s+debug _ = id++{-----------------------------------------------------------------------------+    Combinators - basic+------------------------------------------------------------------------------}+mapP :: (a -> b) -> Pulse a -> Build (Pulse b)+mapP f p1 = do+    p2 <- newPulse "mapP" ({-# SCC mapP #-} fmap f <$> readPulseP p1)+    p2 `dependOn` p1+    return p2++-- | Tag a 'Pulse' with future values of a 'Latch'.+--+-- This is in contrast to 'applyP' which applies the current value+-- of a 'Latch' to a pulse.+tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))+tagFuture x p1 = do+    p2 <- newPulse "tagFuture" $+        fmap . const <$> readLatchFutureP x <*> readPulseP p1+    p2 `dependOn` p1+    return p2++filterJustP :: Pulse (Maybe a) -> Build (Pulse a)+filterJustP p1 = do+    p2 <- newPulse "filterJustP" ({-# SCC filterJustP #-} join <$> readPulseP p1)+    p2 `dependOn` p1+    return p2++unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b)+unsafeMapIOP f p1 = do+        p2 <- newPulse "unsafeMapIOP"+            ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1)+        p2 `dependOn` p1+        return p2+    where+    eval :: Maybe a -> EvalP (Maybe b)+    eval (Just x) = Just <$> liftIO (f x)+    eval Nothing  = return Nothing++mergeWithP+  :: (a -> Maybe c)+  -> (b -> Maybe c)+  -> (a -> b -> Maybe c)+  -> Pulse a+  -> Pulse b+  -> Build (Pulse c)+mergeWithP f g h px py = do+  p <- newPulse "mergeWithP"+       ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py)+  p `dependOn` px+  p `dependOn` py+  return p+  where+    eval Nothing  Nothing  = Nothing+    eval (Just x) Nothing  = f x+    eval Nothing  (Just y) = g y+    eval (Just x) (Just y) = h x y++-- See note [LatchRecursion]+applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)+applyP f x = do+    p <- newPulse "applyP"+        ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x)+    p `dependOn` x+    return p++pureL :: a -> Latch a+pureL = Reactive.Banana.Prim.Low.Plumbing.pureL++-- specialization of   mapL f = applyL (pureL f)+mapL :: (a -> b) -> Latch a -> Latch b+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)++accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)+accumL a p1 = do+    (updateOn, x) <- newLatch a+    p2 <- applyP (mapL (\x f -> f x) x) p1+    updateOn p2+    return (x,p2)++-- specialization of accumL+stepperL :: a -> Pulse a -> Build (Latch a)+stepperL a p = do+    (updateOn, x) <- newLatch a+    updateOn p+    return x++{-----------------------------------------------------------------------------+    Combinators - dynamic event switching+------------------------------------------------------------------------------}+switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)+switchL l pl = mdo+    x <- stepperL l pl+    return $ cachedLatch $ getValueL x >>= getValueL++executeP :: forall a b. 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 :: Maybe (b -> Build a) -> EvalP (Maybe a)+    eval (Just x) = Just <$> liftBuildP (x b)+    eval Nothing  = return Nothing++switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a)+switchP p pp = mdo+    lp <- stepperL p pp+    let+        -- switch to a new parent+        switch = do+            mnew <- readPulseP pp+            case mnew of+                Nothing  -> return ()+                Just new -> liftBuildP $ p2 `changeParent` new+            return Nothing+        -- fetch value from old parent+        eval = readPulseP =<< readLatchP lp++    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())+    p1 `dependOn` pp+    p2 <- newPulse "switchP_out" eval+    p2 `dependOn` p+    p2 `keepAlive` p1+    return p2

@@ -0,0 +1,39 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+module Reactive.Banana.Prim.Mid.Test where++import Reactive.Banana.Prim.Mid++main :: IO ()+main = test_space1++{-----------------------------------------------------------------------------+    Functionality tests+------------------------------------------------------------------------------}+test_accumL1 :: Pulse Int -> BuildIO (Pulse Int)+test_accumL1 p1 = liftBuild $ do+    p2     <- mapP (+) p1+    (l1,_) <- accumL 0 p2+    let l2 =  mapL const l1+    applyP l2 p1++test_recursion1 :: Pulse () -> BuildIO (Pulse Int)+test_recursion1 p1 = liftBuild $ mdo+    p2      <- applyP l2 p1+    p3      <- mapP (const (+1)) p2+    ~(l1,_) <- accumL (0::Int) p3+    let l2  =  mapL const l1+    return p2++-- test garbage collection++{-----------------------------------------------------------------------------+    Space leak tests+------------------------------------------------------------------------------}+test_space1 :: IO ()+test_space1 = runSpaceProfile test_accumL1 [1::Int .. 2 * 10 ^ (4 :: Int)]++test_space2 :: IO ()+test_space2 = runSpaceProfile test_recursion1 $ () <$ [1::Int .. 2 * 10 ^ (4 :: Int)]

@@ -1,43 +0,0 @@-{------------------------------------------------------------------------------    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  hiding (insert)-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) => OrderedBag a -> a -> OrderedBag a-insert (OB xs n) x = OB (Map.insertWith (\new old -> old) x n xs) (n+1)---- | Add a sequence of elements to an ordered bag.------ The ordering is left-to-right. For example, the head of the sequence--- comes after all elements in the bag,--- but before the other elements in the sequence.-inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a-inserts = foldl' insert---- | 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,254 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, RecursiveDo, BangPatterns, ScopedTypeVariables #-}-module Reactive.Banana.Prim.Plumbing where--import           Control.Monad                                (join)-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-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.IORef-import           Data.List                                    (sortBy)-import           Data.Monoid-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe--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 = liftIO $ do-    key <- Lazy.newKey-    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 = liftIO $ do-    key <- Lazy.newKey-    newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = return Nothing-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = "neverP"-        }---- | 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 :: forall a. a -> Build (Pulse a -> Build (), Latch a)-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 :: Pulse a -> Build ()-        updateOn p = do-            w  <- liftIO $ mkWeakRefValue latch latch-            lw <- liftIO $ newRef $ LatchWrite-                { _evalLW  = maybe err id <$> readPulseP p-                , _latchLW = w-                }-            -- 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 :: 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 = 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-------------------------------------------------------------------------------}-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'')--buildLater :: Build () -> Build ()-buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)---- | 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 = (\(_,x) -> x) <$> RW.ask--readLatchB :: Latch a -> Build a-readLatchB = liftIO . readLatchIO--dependOn :: Pulse child -> Pulse parent -> Build ()-dependOn child parent = (P parent) `addChild` (P child)--keepAlive :: Pulse child -> Pulse parent -> Build ()-keepAlive child parent = liftIO $ mkWeakRefValue child parent >> return ()--addChild :: SomeNode -> SomeNode -> Build ()-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 = RW.tell $ BuildW (mempty, mempty, Action x, mempty)--{------------------------------------------------------------------------------    EvalL monad-------------------------------------------------------------------------------}--- | 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 ()--getValueL :: Latch a -> EvalL a-getValueL latch = do-    Latch{..} <- readRef latch-    _evalL--{------------------------------------------------------------------------------    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)--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 p = do-    Pulse{..} <- readRef p-    join . Lazy.lookup _keyP <$> RWS.get--writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()-writePulseP key a = do-    s <- RWS.get-    RWS.put $ Lazy.insert key a s--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 :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a-unwrapEvalP r m = RWS.run m r--wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a-wrapEvalP m = RWS.R m

@@ -1,39 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Test where--import Control.Applicative-import Reactive.Banana.Prim--main = test_space1--{------------------------------------------------------------------------------    Functionality tests-------------------------------------------------------------------------------}-test_accumL1 :: Pulse Int -> BuildIO (Pulse Int)-test_accumL1 p1 = liftBuild $ do-    p2     <- mapP (+) p1-    (l1,_) <- accumL 0 p2-    let l2 =  mapL const l1-    p3     <- applyP l2 p1-    return p3--test_recursion1 :: Pulse () -> BuildIO (Pulse Int)-test_recursion1 p1 = liftBuild $ mdo-    p2      <- applyP l2 p1-    p3      <- mapP (const (+1)) p2-    ~(l1,_) <- accumL (0::Int) p3-    let l2  =  mapL const l1-    return p2---- test garbage collection--{------------------------------------------------------------------------------    Space leak tests-------------------------------------------------------------------------------}-test_space1 = runSpaceProfile test_accumL1    $ [1..2*10^4]-test_space2 = runSpaceProfile test_recursion1 $ () <$ [1..2*10^4]--

@@ -1,237 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module Reactive.Banana.Prim.Types where--import           Control.Monad.Trans.RWSIO-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.ReaderWriterIO-import           Data.Functor-import           Data.Hashable-import           Data.Monoid (Monoid, mempty, mappend)-import           Data.Semigroup-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe-import           System.Mem.Weak--import Reactive.Banana.Prim.Graph            (Graph)-import Reactive.Banana.Prim.OrderedBag as OB (OrderedBag, empty)-import Reactive.Banana.Prim.Util--{------------------------------------------------------------------------------    Network-------------------------------------------------------------------------------}--- | A 'Network' represents the state of a pulse/latch network,-data Network = Network-    { nTime           :: !Time                 -- Current time.-    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.-    , nAlwaysP        :: !(Maybe (Pulse ()))   -- Pulse that always fires.-    }--type Inputs        = ([SomeNode], Lazy.Vault)-type EvalNetwork a = Network -> IO (a, Network)-type Step          = EvalNetwork (IO ())--emptyNetwork :: Network-emptyNetwork = Network-    { nTime    = next beginning-    , nOutputs = OB.empty-    , nAlwaysP = Nothing-    }--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-    --          )--instance Semigroup BuildW where-    BuildW x <> BuildW y = BuildW (x <> y)--instance Monoid BuildW where-    mempty  = BuildW mempty-    mappend = (<>)--type BuildIO = Build--type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)])--{------------------------------------------------------------------------------    Synonyms-------------------------------------------------------------------------------}--- | Priority used to determine evaluation order for pulses.-type Level = Int--ground :: Level-ground = 0---- | 'IO' actions as a monoid with respect to sequencing.-newtype Action = Action { doit :: IO () }-instance Semigroup Action where-    Action x <> Action y = Action (x >> y)-instance Monoid Action where-    mempty = Action $ return ()-    mappend = (<>)---- | Lens-like functionality.-data Lens s a = Lens (s -> a) (a -> s -> s)--set :: Lens s a -> a -> s -> s-set (Lens _   set)   = set--update :: Lens s a -> (a -> a) -> s -> s-update (Lens get set) f = \s -> set (f $ get s) s--{------------------------------------------------------------------------------    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.-    }--instance Show (Pulse a) where-    show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p)--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.-    }--type Output  = Ref Output'-data Output' = Output-    { _evalO     :: EvalP EvalO-    }-instance Eq Output where (==) = equalRef--data SomeNode-    = forall a. P (Pulse a)-    | L LatchWrite-    | O Output--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) = equalRef x y-    (L x) == (L y) = equalRef x y-    (O x) == (O y) = equalRef x y--{-# INLINE mkWeakNodeValue #-}-mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)-mkWeakNodeValue (P x) = mkWeakRefValue x-mkWeakNodeValue (L x) = mkWeakRefValue x-mkWeakNodeValue (O x) = mkWeakRefValue x---- Lenses for various parameters-seenP :: Lens (Pulse' a) Time-seenP = Lens _seenP  (\a s -> s { _seenP = a })--seenL :: Lens (Latch' a) Time-seenL = Lens _seenL  (\a s -> s { _seenL = a })--valueL :: Lens (Latch' a) a-valueL = Lens _valueL (\a s -> s { _valueL = a })--parentsP :: Lens (Pulse' a) [Weak SomeNode]-parentsP = Lens _parentsP (\a s -> s { _parentsP = a })--childrenP :: Lens (Pulse' a) [Weak SomeNode]-childrenP = Lens _childrenP (\a s -> s { _childrenP = a })--levelP :: Lens (Pulse' a) Int-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-------------------------------------------------------------------------------}-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 Semigroup Time where-    T x <> T y = T (max x y)--instance Monoid Time where-    mappend = (<>)-    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`.---}

@@ -1,61 +0,0 @@-{------------------------------------------------------------------------------    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-------------------------------------------------------------------------------}-mkWeakIORefValue :: IORef a -> value -> IO (Weak value)-mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) val = GHC.IO $ \s ->-  case GHC.mkWeakNoFinalizer# r# val s of (# s1, w #) -> (# s1, GHC.Weak w #)--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

@@ -1,253 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Test cases and examples-------------------------------------------------------------------------------}-{-# LANGUAGE FlexibleContexts, Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}--import Control.Arrow-import Control.Monad (when, join)--import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.HUnit (testCase)--import Test.HUnit (assert, Assertion)---- import Test.QuickCheck--- import Test.QuickCheck.Property--import Control.Applicative-import Reactive.Banana.Test.Plumbing---main = defaultMain-    [ testGroup "Simple"-        [ testModelMatch "id"      id-        , testModelMatch "never1"  never1-        , testModelMatch "fmap1"   fmap1-        , testModelMatch "filter1" filter1-        , testModelMatch "filter2" filter2-        , testModelMatchM "accumE1" accumE1-        ]-    , testGroup "Complex"-        [ testModelMatchM "counter"     counter-        , testModelMatch "double"      double-        , testModelMatch "sharing"     sharing-        , testModelMatch "mergeFilter" mergeFilter-        , testModelMatchM "recursive1A"  recursive1A-        , testModelMatchM "recursive1B"  recursive1B-        , testModelMatchM "recursive2"  recursive2-        , testModelMatchM "recursive3"  recursive3-        , testModelMatchM "recursive4a" recursive4a-        -- , testModelMatchM "recursive4b" recursive4b-        , testModelMatchM "accumBvsE"   accumBvsE-        ]-    , testGroup "Dynamic Event Switching"-        [ testModelMatch  "observeE_id"         observeE_id-        , testModelMatch  "observeE_stepper"    observeE_stepper-        , testModelMatchM "valueB_immediate"    valueB_immediate-        -- , testModelMatchM "valueB_recursive1" valueB_recursive1-        -- , testModelMatchM "valueB_recursive2" valueB_recursive2-        , testModelMatchM "dynamic_apply"       dynamic_apply-        , testModelMatchM "switchE1"            switchE1-        , testModelMatchM "switchB1"            switchB1-        , testModelMatchM "switchB2"            switchB2-        ]-    , testGroup "Regression tests"-        [ testModelMatchM "issue79" issue79-        ]-    -- TODO:-    --  * algebraic laws-    --  * larger examples-    --  * quickcheck-    ]--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}-matchesModel-    :: (Show b, Eq b)-    => (Event a -> Moment (Event b)) -> [a] -> IO Bool-matchesModel f xs = do-    bs1 <- return $ interpretModel f (singletons xs)-    bs2 <- interpretGraph f (singletons xs)-    -- bs3 <- interpretFrameworks f xs-    let bs = [bs1,bs2]-    let b = all (==bs1) bs-    when (not b) $ mapM_ print bs-    return b--singletons = map Just---- test whether model matches-testModelMatchM-    :: (Show b, Eq b)-    => String -> (Event Int -> Moment (Event b)) -> Test-testModelMatchM name f = testCase name $ assert $ matchesModel f [1..8::Int]-testModelMatch name f = testModelMatchM name (return . f)---- individual tests for debugging-testModel :: (Event Int -> Event b) -> [Maybe b]-testModel f = interpretModel (return . f) $ singletons [1..8::Int]-testGraph f = interpretGraph (return . f) $ singletons [1..8::Int]--testModelM f = interpretModel f $ singletons [1..8::Int]-testGraphM f = interpretGraph f $ singletons [1..8::Int]---{------------------------------------------------------------------------------    Tests-------------------------------------------------------------------------------}-never1 :: Event Int -> Event Int-never1    = const never-fmap1     = fmap (+1)--filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing)-filter1   = filterE (>= 3)-filter2   = filterE (>= 3) . fmap (subtract 1)-accumE1   = accumE 0 . ((+1) <$)--counter e = do-    bcounter <- accumB 0 $ fmap (\_ -> (+1)) e-    return $ applyE (pure const <*> bcounter) e--merge e1 e2 = mergeWith id id (++) (list e1) (list e2)-    where list = fmap (:[])--double e  = merge e e-sharing e = merge e1 e1-    where e1 = filterE (< 3) e--mergeFilter e1 = mergeWith id id (+) e2 e3-    where-    e3 = fmap (+1) $ filterE even e1-    e2 = fmap (+1) $ filterE odd  e1--recursive1A e1 = mdo-    let e2 = applyE ((+) <$> b) e1-    b <- stepperB 0 e2-    return e2-recursive1B e1 = mdo-    b <- stepperB 0 e2-    let e2 = applyE ((+) <$> b) e1-    return e2--recursive2 e1 = mdo-    b  <- fmap ((+) <$>) $ stepperB 0 e3-    let e2 = applyE b e1-    let e3 = applyE (id <$> b) e1   -- actually equal to e2-    return e2--type Dummy = Int---- Counter that can be decreased as long as it's >= 0 .-recursive3 :: Event Dummy -> Moment (Event Int)-recursive3 edec = mdo-    bcounter <- accumB 4 $ (subtract 1) <$ ecandecrease-    let ecandecrease = whenE ((>0) <$> bcounter) edec-    return $ applyE (const <$> bcounter) ecandecrease---- Recursive 4 is an example reported by Merijn Verstraaten---   https://github.com/HeinrichApfelmus/reactive-banana/issues/56--- Minimization:-recursive4a :: Event Int -> Moment (Event (Bool, Int))-recursive4a eInput = mdo-    focus       <- stepperB False $ fst <$> resultE-    let resultE = resultB <@ eInput-    let resultB = (,) <$> focus <*> pureB 0-    return $ resultB <@ eInput--{---- Full example:-recursive4b :: Event Int -> Event (Bool, Int)-recursive4b eInput = result <@ eInput-    where-    focus     = stepperB False $ fst <$> result <@ eInput-    interface = (,) <$> focus <*> cntrVal-    (cntrVal, focusChange) = counter eInput focus-    result    = stepperB id ((***id) <$> focusChange) <*> interface--    filterApply :: Behavior (a -> Bool) -> Event a -> Event a-    filterApply b e = filterJust $ sat <$> b <@> e-        where sat p x = if p x then Just x else Nothing--    counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool))-    counter input active = (result, not <$ eq)-        where-        result = accumB 0 $ (+) <$> neq-        eq     = filterApply ((==) <$> result) input-        neq    = filterApply ((/=) <$> result) input--}---- Test 'accumE' vs 'accumB'.-accumBvsE :: Event Dummy -> Moment (Event [Int])-accumBvsE e = mdo-    e1 <- accumE 0 ((+1) <$ e)--    b  <- accumB 0 ((+1) <$ e)-    let e2 = applyE (const <$> b) e--    return $ merge e1 e2--observeE_id = observeE . fmap return -- = id--observeE_stepper :: Event Int -> Event Int-observeE_stepper e = observeE $ (valueB =<< mb) <$ e-    where-    mb :: Moment (Behavior Int)-    mb = stepper 0 e--valueB_immediate e = do-    x <- valueB =<< stepper 0 e-    return $ x <$ e--{-- The following tests would need to use the  valueBLater  combinator--valueB_recursive1 e1 = mdo-    _ <- initialB b-    let b = stepper 0 e1-    return $ b <@ e1--valueB_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-    b <- stepper 0 e-    return $ observeE $ (valueB b) <$ e-    -- = stepper 0 e <@ e--switchE1 e = switchE (e <$ e)--switchB1 e = do-    b0 <- stepper 0 e-    b1 <- stepper 0 e-    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e-    return $ b <@ e--switchB2 e = do-    b0 <- stepper 0 $ filterE even e-    b1 <- stepper 1 $ filterE odd  e-    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e-    return $ b <@ e--{------------------------------------------------------------------------------    Regression tests-------------------------------------------------------------------------------}-issue79 :: Event Dummy -> Moment (Event String)-issue79 inputEvent = mdo-    let-        appliedEvent  = (\_ _ -> 1) <$> lastValue <@> inputEvent-        filteredEvent = filterE (const True) appliedEvent-        fmappedEvent  = fmap id (filteredEvent)-    lastValue <- stepper 1 $ fmappedEvent--    let outputEvent = mergeWith id id (++)-            (const "filtered event" <$> filteredEvent)-            (((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent)--    return $ outputEvent-

@@ -1,106 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}--- * Synopsis--- | Merge model and implementation into a single type. Not pretty.--module Reactive.Banana.Test.Plumbing where--import Control.Applicative-import Control.Monad (liftM, ap)-import Control.Monad.Fix--import qualified Reactive.Banana.Model as X-import qualified Reactive.Banana.Internal.Combinators as Y--{------------------------------------------------------------------------------    Types as pairs-------------------------------------------------------------------------------}--data Event    a = E (X.Event    a) (Y.Event    a)-data Behavior a = B (X.Behavior a) (Y.Behavior a)-data Moment   a = M (X.Moment   a) (Y.Moment   a)---- pair extractions-fstE (E x _) = x; sndE (E _ y) = y-fstB (B x _) = x; sndB (B _ y) = y-fstM (M x _) = x; sndM (M _ y) = y---- partial embedding functions-ex x = E x undefined; ey y = E undefined y-bx x = B x undefined; by y = B undefined y-mx x = M x undefined; my y = M undefined y---- interpretation-interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]-interpretModel f = X.interpret (fmap fstE . fstM . f . ex)--interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey)--{------------------------------------------------------------------------------    Primitive combinators-------------------------------------------------------------------------------}-never                               = E X.never Y.never-filterJust (E x y)                  = E (X.filterJust x) (Y.filterJust y)-mergeWith f g h (E x1 y1) (E x2 y2) = E (X.mergeWith f g h x1 x2) (Y.mergeWith f g h y1 y2)-mapE f (E x y)                      = E (fmap f x) (Y.mapE f y)-applyE ~(B x1 y1) (E x2 y2)         = E (X.apply x1 x2) (Y.applyE y1 y2)--instance Functor Event where fmap = mapE--pureB a                         = B (pure a) (Y.pureB a)-applyB (B x1 y1) (B x2 y2)      = B (x1 <*> x2) (Y.applyB y1 y2)-mapB f (B x y)                  = B (fmap f x) (Y.mapB f y)--instance Functor     Behavior where fmap = mapB-instance Applicative Behavior where pure = pureB; (<*>) = applyB--instance Functor Moment where fmap = liftM-instance Applicative Moment where-    pure  = return-    (<*>) = ap-instance Monad Moment where-    return a = M (return a) (return a)-    ~(M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g)-instance MonadFix Moment where-    mfix f = M (mfix fx) (mfix fy)-        where-        fx a = let M x _ = f a in x-        fy a = let M _ y = f a in y---accumE   a ~(E x y) = M-    (fmap ex $ X.accumE a x)-    (fmap ey $ Y.accumE a y)-stepperB a ~(E x y) = M-    (fmap bx $ X.stepper  a x)-    (fmap by $ Y.stepperB a y)-stepper            = stepperB--valueB ~(B x y) = M (X.valueB x) (Y.valueB y)--observeE :: Event (Moment a) -> Event a-observeE (E x y) = E (X.observeE $ fmap fstM x) (Y.observeE $ Y.mapE sndM y)--switchE :: Event (Event a) -> Moment (Event a)-switchE (E x y) = M-    (fmap ex $ X.switchE $   fmap (fstE) x)-    (fmap ey $ Y.switchE $ Y.mapE (sndE) y)--switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)-switchB (B x y) (E xe ye) = M-    (fmap bx $ X.switchB x $   fmap (fstB) xe)-    (fmap by $ Y.switchB y $ Y.mapE (sndB) ye)--{------------------------------------------------------------------------------    Derived combinators-------------------------------------------------------------------------------}-accumB acc e1 = do-    e2 <- accumE acc e1-    stepperB acc e2-whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)--infixl 4 <@>, <@-b <@ e  = applyE (const <$> b) e-b <@> e = applyE b e

@@ -1,3 +1,5 @@+{-# language CPP #-}+ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}@@ -8,15 +10,30 @@     Future(..),     ) where -import Data.Semigroup import Control.Applicative-import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix import Data.String (IsString(..))+import Control.Monad.Trans.Accum (AccumT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) -import qualified Reactive.Banana.Internal.Combinators as Prim+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS (RWST)+import qualified Control.Monad.Trans.Writer.CPS as CPS (WriterT)+#endif +import qualified Reactive.Banana.Prim.High.Combinators as Prim+ {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}@@ -60,7 +77,7 @@ -- > mempty :: Event a -- > mempty = never instance Semigroup a => Monoid (Event a) where-    mempty  = E $ Prim.never+    mempty  = E Prim.never     mappend = (<>)  @@ -187,7 +204,23 @@  instance MonadMoment Moment   where liftMoment = id instance MonadMoment MomentIO where liftMoment = MIO . unM+instance (MonadMoment m, Monoid w) => MonadMoment (AccumT w m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (ExceptT e m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (IdentityT m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (MaybeT m) where liftMoment = lift . liftMoment+instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.RWST r w s m) where liftMoment = lift . liftMoment+instance (MonadMoment m, Monoid w) => MonadMoment (Strict.RWST r w s m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (ReaderT r m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (Lazy.StateT s m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (Strict.StateT s m) where liftMoment = lift . liftMoment+instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.WriterT w m) where liftMoment = lift . liftMoment+instance (MonadMoment m, Monoid w) => MonadMoment (Strict.WriterT w m) where liftMoment = lift . liftMoment +#if MIN_VERSION_transformers(0,5,6)+instance MonadMoment m => MonadMoment (CPS.RWST r w s m) where liftMoment = lift . liftMoment+instance MonadMoment m => MonadMoment (CPS.WriterT w m) where liftMoment = lift . liftMoment+#endif+ -- boilerplate class instances instance Functor Moment where fmap f = M . fmap f . unM instance Monad Moment where@@ -198,6 +231,12 @@     f <*> a = M $ unM f <*> unM a instance MonadFix Moment where mfix f = M $ mfix (unM . f) +instance Semigroup a => Semigroup (Moment a) where+    (<>) = liftA2 (<>)+instance Monoid a => Monoid (Moment a) where+    mempty = pure mempty++ instance Functor MomentIO where fmap f = MIO . fmap f . unMIO instance Monad MomentIO where     return  = MIO . return@@ -206,3 +245,8 @@     pure    = MIO . pure     f <*> a = MIO $ unMIO f <*> unMIO a instance MonadFix MomentIO where mfix f = MIO $ mfix (unMIO . f)++instance Semigroup a => Semigroup (MomentIO a) where+    (<>) = liftA2 (<>)+instance Monoid a => Monoid (MomentIO a) where+    mempty = pure mempty

@@ -0,0 +1,248 @@+{-----------------------------------------------------------------------------+    reactive-banana++    Test cases and examples+------------------------------------------------------------------------------}+{-# LANGUAGE FlexibleContexts, Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}++import Control.Arrow+import Control.Monad (when, join)++import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.HUnit (testCase, assertBool)++import Control.Applicative+import Plumbing+++main = defaultMain $ testGroup "Tests"+    [ testGroup "Simple"+        [ testModelMatch "id"      id+        , testModelMatch "never1"  never1+        , testModelMatch "fmap1"   fmap1+        , testModelMatch "filter1" filter1+        , testModelMatch "filter2" filter2+        , testModelMatchM "accumE1" accumE1+        ]+    , testGroup "Complex"+        [ testModelMatchM "counter"     counter+        , testModelMatch "double"      double+        , testModelMatch "sharing"     sharing+        , testModelMatch "mergeFilter" mergeFilter+        , testModelMatchM "recursive1A"  recursive1A+        , testModelMatchM "recursive1B"  recursive1B+        , testModelMatchM "recursive2"  recursive2+        , testModelMatchM "recursive3"  recursive3+        , testModelMatchM "recursive4a" recursive4a+        -- , testModelMatchM "recursive4b" recursive4b+        , testModelMatchM "accumBvsE"   accumBvsE+        ]+    , testGroup "Dynamic Event Switching"+        [ testModelMatch  "observeE_id"         observeE_id+        , testModelMatch  "observeE_stepper"    observeE_stepper+        , testModelMatchM "valueB_immediate"    valueB_immediate+        -- , testModelMatchM "valueB_recursive1" valueB_recursive1+        -- , testModelMatchM "valueB_recursive2" valueB_recursive2+        , testModelMatchM "dynamic_apply"       dynamic_apply+        , testModelMatchM "switchE1"            switchE1+        , testModelMatchM "switchB1"            switchB1+        , testModelMatchM "switchB2"            switchB2+        ]+    , testGroup "Regression tests"+        [ testModelMatchM "issue79" issue79+        ]+    -- TODO:+    --  * algebraic laws+    --  * larger examples+    --  * quickcheck+    ]++{-----------------------------------------------------------------------------+    Testing+------------------------------------------------------------------------------}+matchesModel+    :: (Show b, Eq b)+    => (Event a -> Moment (Event b)) -> [a] -> IO Bool+matchesModel f xs = do+    bs1 <- return $ interpretModel f (singletons xs)+    bs2 <- interpretGraph f (singletons xs)+    -- bs3 <- interpretFrameworks f xs+    let bs = [bs1,bs2]+    let b = all (==bs1) bs+    when (not b) $ mapM_ print bs+    return b++singletons = map Just++-- test whether model matches+testModelMatchM+    :: (Show b, Eq b)+    => String -> (Event Int -> Moment (Event b)) -> TestTree+testModelMatchM name f = testCase name $ assertBool "matchesModel" =<< matchesModel f [1..8::Int]+testModelMatch name f = testModelMatchM name (return . f)++-- individual tests for debugging+testModel :: (Event Int -> Event b) -> [Maybe b]+testModel f = interpretModel (return . f) $ singletons [1..8::Int]+testGraph f = interpretGraph (return . f) $ singletons [1..8::Int]++testModelM f = interpretModel f $ singletons [1..8::Int]+testGraphM f = interpretGraph f $ singletons [1..8::Int]+++{-----------------------------------------------------------------------------+    Tests+------------------------------------------------------------------------------}+never1 :: Event Int -> Event Int+never1    = const never+fmap1     = fmap (+1)++filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing)+filter1   = filterE (>= 3)+filter2   = filterE (>= 3) . fmap (subtract 1)+accumE1   = accumE 0 . ((+1) <$)++counter e = do+    bcounter <- accumB 0 $ fmap (\_ -> (+1)) e+    return $ applyE (pure const <*> bcounter) e++merge e1 e2 = mergeWith id id (++) (list e1) (list e2)+    where list = fmap (:[])++double e  = merge e e+sharing e = merge e1 e1+    where e1 = filterE (< 3) e++mergeFilter e1 = mergeWith id id (+) e2 e3+    where+    e3 = fmap (+1) $ filterE even e1+    e2 = fmap (+1) $ filterE odd  e1++recursive1A e1 = mdo+    let e2 = applyE ((+) <$> b) e1+    b <- stepperB 0 e2+    return e2+recursive1B e1 = mdo+    b <- stepperB 0 e2+    let e2 = applyE ((+) <$> b) e1+    return e2++recursive2 e1 = mdo+    b  <- fmap ((+) <$>) $ stepperB 0 e3+    let e2 = applyE b e1+    let e3 = applyE (id <$> b) e1   -- actually equal to e2+    return e2++type Dummy = Int++-- Counter that can be decreased as long as it's >= 0 .+recursive3 :: Event Dummy -> Moment (Event Int)+recursive3 edec = mdo+    bcounter <- accumB 4 $ (subtract 1) <$ ecandecrease+    let ecandecrease = whenE ((>0) <$> bcounter) edec+    return $ applyE (const <$> bcounter) ecandecrease++-- Recursive 4 is an example reported by Merijn Verstraaten+--   https://github.com/HeinrichApfelmus/reactive-banana/issues/56+-- Minimization:+recursive4a :: Event Int -> Moment (Event (Bool, Int))+recursive4a eInput = mdo+    focus       <- stepperB False $ fst <$> resultE+    let resultE = resultB <@ eInput+    let resultB = (,) <$> focus <*> pureB 0+    return $ resultB <@ eInput++{-+-- Full example:+recursive4b :: Event Int -> Event (Bool, Int)+recursive4b eInput = result <@ eInput+    where+    focus     = stepperB False $ fst <$> result <@ eInput+    interface = (,) <$> focus <*> cntrVal+    (cntrVal, focusChange) = counter eInput focus+    result    = stepperB id ((***id) <$> focusChange) <*> interface++    filterApply :: Behavior (a -> Bool) -> Event a -> Event a+    filterApply b e = filterJust $ sat <$> b <@> e+        where sat p x = if p x then Just x else Nothing++    counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool))+    counter input active = (result, not <$ eq)+        where+        result = accumB 0 $ (+) <$> neq+        eq     = filterApply ((==) <$> result) input+        neq    = filterApply ((/=) <$> result) input+-}++-- Test 'accumE' vs 'accumB'.+accumBvsE :: Event Dummy -> Moment (Event [Int])+accumBvsE e = mdo+    e1 <- accumE 0 ((+1) <$ e)++    b  <- accumB 0 ((+1) <$ e)+    let e2 = applyE (const <$> b) e++    return $ merge e1 e2++observeE_id = observeE . fmap return -- = id++observeE_stepper :: Event Int -> Event Int+observeE_stepper e = observeE $ (valueB =<< mb) <$ e+    where+    mb :: Moment (Behavior Int)+    mb = stepper 0 e++valueB_immediate e = do+    x <- valueB =<< stepper 0 e+    return $ x <$ e++{-- The following tests would need to use the  valueBLater  combinator++valueB_recursive1 e1 = mdo+    _ <- initialB b+    let b = stepper 0 e1+    return $ b <@ e1++valueB_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+    b <- stepper 0 e+    return $ observeE $ (valueB b) <$ e+    -- = stepper 0 e <@ e++switchE1 e = switchE e (e <$ e)++switchB1 e = do+    b0 <- stepper 0 e+    b1 <- stepper 0 e+    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e+    return $ b <@ e++switchB2 e = do+    b0 <- stepper 0 $ filterE even e+    b1 <- stepper 1 $ filterE odd  e+    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e+    return $ b <@ e++{-----------------------------------------------------------------------------+    Regression tests+------------------------------------------------------------------------------}+issue79 :: Event Dummy -> Moment (Event String)+issue79 inputEvent = mdo+    let+        appliedEvent  = (\_ _ -> 1) <$> lastValue <@> inputEvent+        filteredEvent = filterE (const True) appliedEvent+        fmappedEvent  = fmap id (filteredEvent)+    lastValue <- stepper 1 $ fmappedEvent++    let outputEvent = mergeWith id id (++)+            (const "filtered event" <$> filteredEvent)+            (((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent)++    return $ outputEvent+

@@ -0,0 +1,106 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- * Synopsis+-- | Merge model and implementation into a single type. Not pretty.++module Plumbing where++import Control.Applicative+import Control.Monad (liftM, ap)+import Control.Monad.Fix++import qualified Reactive.Banana.Model as X+import qualified Reactive.Banana as Y++{-----------------------------------------------------------------------------+    Types as pairs+------------------------------------------------------------------------------}++data Event    a = E (X.Event    a) (Y.Event    a)+data Behavior a = B (X.Behavior a) (Y.Behavior a)+data Moment   a = M (X.Moment   a) (Y.Moment   a)++-- pair extractions+fstE (E x _) = x; sndE (E _ y) = y+fstB (B x _) = x; sndB (B _ y) = y+fstM (M x _) = x; sndM (M _ y) = y++-- partial embedding functions+ex x = E x undefined; ey y = E undefined y+bx x = B x undefined; by y = B undefined y+mx x = M x undefined; my y = M undefined y++-- interpretation+interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]+interpretModel f = X.interpret (fmap fstE . fstM . f . ex)++interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey)++{-----------------------------------------------------------------------------+    Primitive combinators+------------------------------------------------------------------------------}+never                               = E X.never Y.never+filterJust (E x y)                  = E (X.filterJust x) (Y.filterJust y)+mergeWith f g h (E x1 y1) (E x2 y2) = E (X.mergeWith f g h x1 x2) (Y.mergeWith f g h y1 y2)+mapE f (E x y)                      = E (fmap f x) (fmap f y)+applyE ~(B x1 y1) (E x2 y2)         = E (X.apply x1 x2) (y1 Y.<@> y2)++instance Functor Event where fmap = mapE++pureB a                         = B (pure a) (pure a)+applyB (B x1 y1) (B x2 y2)      = B (x1 <*> x2) (y1 <*> y2)+mapB f (B x y)                  = B (fmap f x) (fmap f y)++instance Functor     Behavior where fmap = mapB+instance Applicative Behavior where pure = pureB; (<*>) = applyB++instance Functor Moment where fmap = liftM+instance Applicative Moment where+    pure  = return+    (<*>) = ap+instance Monad Moment where+    return a = M (return a) (return a)+    ~(M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g)+instance MonadFix Moment where+    mfix f = M (mfix fx) (mfix fy)+        where+        fx a = let M x _ = f a in x+        fy a = let M _ y = f a in y+++accumE   a ~(E x y) = M+    (ex <$> X.accumE a x)+    (ey <$> Y.accumE a y)+stepperB a ~(E x y) = M+    (bx <$> X.stepper a x)+    (by <$> Y.stepper a y)+stepper            = stepperB++valueB ~(B x y) = M (X.valueB x) (Y.valueB y)++observeE :: Event (Moment a) -> Event a+observeE (E x y) = E (X.observeE $ fmap fstM x) (Y.observeE $ fmap sndM y)++switchE :: Event a -> Event (Event a) -> Moment (Event a)+switchE (E x0 y0) (E x y) = M+    (fmap ex $ X.switchE x0 $ fstE <$> x)+    (fmap ey $ Y.switchE y0 $ sndE <$> y)++switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB (B x y) (E xe ye) = M+    (fmap bx $ X.switchB x $ fmap fstB xe)+    (fmap by $ Y.switchB y $ fmap sndB ye)++{-----------------------------------------------------------------------------+    Derived combinators+------------------------------------------------------------------------------}+accumB acc e1 = do+    e2 <- accumE acc e1+    stepperB acc e2+whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)++infixl 4 <@>, <@+b <@ e  = applyE (const <$> b) e+b <@> e = applyE b e