packages feed

reactive-banana 0.7.1.3 → 1.3.2.0

raw patch · 55 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,257 @@+Changelog for the `reactive-banana` package+-------------------------------------------++**Version 1.3.2.0** (2023-01-22)++* Fixed multiple space leaks for dynamic event switching by completely redesigning low-level internals. Added automated tests on garbage collection and space leaks in order to make sure that the leaks stay fixed. [#261][], [#267][], [#268][]++  [#268]: https://github.com/HeinrichApfelmus/reactive-banana/pull/268+  [#267]: https://github.com/HeinrichApfelmus/reactive-banana/pull/267+  [#261]: https://github.com/HeinrichApfelmus/reactive-banana/issues/261++**Version 1.3.1.0** (2022-08-11)++* Various internal performance improvements. [#257][], [#258][]+* Fix a space leak in dynamic event switching. [#256][]+* Reduce memory usage of `stepper`/`accumB`. [#260][]+* Prevent a deadlock if the network crashes when evaluating a `Behavior` or `Event`. [#262][]++  [#257]: https://github.com/HeinrichApfelmus/reactive-banana/pull/257+  [#258]: https://github.com/HeinrichApfelmus/reactive-banana/pull/258+  [#256]: https://github.com/HeinrichApfelmus/reactive-banana/pull/256+  [#262]: https://github.com/HeinrichApfelmus/reactive-banana/pull/262+  [#260]: https://github.com/HeinrichApfelmus/reactive-banana/pull/260++**Version 1.3.0.0** (2022-03-28)++* 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][]+* Replace a use of `foldl` with `foldl'`. [#212][]+* Simplify the internal `mkWeakIORef` function. [#154][]+* Add `merge` and `mergeWith` combinators. [#163][], [#220][]+* Make internal SCC pragmas compatible with the GHC 9.0 parser. [#208][]+* Change `insertWith (flip (++))` to `insertWith (++)` in `insertEdge`. [#211][]+* Add `Semigroup a => Semigroup (Behavior a)` and `Monoid a => Monoid (Behavior a)` instances. [#185][]+* Loosen the upper-bound for `hashable` and `semigroups`. [#205][]++  [#154]: https://github.com/HeinrichApfelmus/reactive-banana/pull/154+  [#163]: https://github.com/HeinrichApfelmus/reactive-banana/pull/163+  [#185]: https://github.com/HeinrichApfelmus/reactive-banana/pull/185+  [#205]: https://github.com/HeinrichApfelmus/reactive-banana/pull/205+  [#208]: https://github.com/HeinrichApfelmus/reactive-banana/pull/208+  [#209]: https://github.com/HeinrichApfelmus/reactive-banana/pull/209+  [#211]: https://github.com/HeinrichApfelmus/reactive-banana/pull/211+  [#212]: https://github.com/HeinrichApfelmus/reactive-banana/pull/212+  [#220]: https://github.com/HeinrichApfelmus/reactive-banana/pull/219++**version 1.2.1.0**++* Add `Num`, `Floating`, `Fractional`, and `IsString` instances for `Behavior`. [#34][]+* Support `containers-0.6`. [#191][]++  [#34]: https://github.com/HeinrichApfelmus/reactive-banana/pull/34+  [#191]: https://github.com/HeinrichApfelmus/reactive-banana/pull/191++**version 1.2.0.0**++* Make `MonadFix` superclass of `MonadMoment`. [#128][]+* Add `Semigroup` and `Monoid` instances for `Event`. [#104][]+* Semigroup compatibility with GHC 8.4.1 [#168][]+* Increased upper-bound on `pqueue`.++  [#128]: https://github.com/HeinrichApfelmus/reactive-banana/pull/128+  [#104]: https://github.com/HeinrichApfelmus/reactive-banana/issues/104+  [#168]: https://github.com/HeinrichApfelmus/reactive-banana/pull/168++**version 1.1.0.1**++* Adapt library to work with GHC-8.0.1.++**version 1.1.0.0**++* Fix bug: Types of `switchB` and `switchE` need to be in the `Moment` monad.+* Clean up and simplify model implementation in the `Reactive.Banana.Model` module.+* Update type signatures of the `interpret*` functions to make it easier to try FRP functions in the REPL.+* Remove `showNetwork` function.++**version 1.0.0.1**++* Improve documentation.+    * Add prose section on recursion.+    * Improve explanation for the `changes` function.+* Bump `transfomers` dependency.+* Remove defunct `UseExtensions` flag from cabal file.++**version 1.0.0.0**++The API has been redesigned significantly in this version!++* Remove phantom type parameter `t` from `Event`, `Behavior` and `Moment` types.+    * Change accumulation functions (`accumB`, `accumE`, `stepper`) to have a monadic result type.+    * Merge module `Reactive.Banana.Switch` into module `Reactive.Banana.Combinators`.+    * Simplify types of the switching functions (`switchE`, `switchB`, `observeB`, `execute`).+    * Remove functions `trimE` and `trimB`.+    * Remove types `AnyMoment` and `Identity`.+* Remove `Frameworks` class constraint, use `MomentIO` type instead.+    * Add class `MonadMoment` for both polymorphism over the `Moment` and `MomentIO` types.+* Change type `Event` to only allow a single event per moment in time.+    * Remove function `union`. Use `unionWith` instead.+    * Change function `unions` to only merge events of type `Event (a -> a)`.+* Remove module `Reactive.Banana.Experimental.Calm`.+* Change the model implementation in the module `Reactive.Banana.Model` to the new API as well.++Other changes:++* Add `mapEventIO` utility function to build an Event that contains the result of an IO computation.+* Add `newBehavior` utility function to build a Behavior that can be updated with a `Handler`.+* Add illustrations to the API documentation.++**version 0.9.0.0**++* Implement garbage collection for dynamically switched events.+* Fix issue [#79][] where recursive declarations would sometimes result in dropped events.+* Limit value recursion in the `Moment` monad slightly.+* Change `initial` and `valueB` to behave subtly different when it comes to value recursion in the `Moment` monad.+* Add `Functor`, `Applicative` and `Monad` instances for the `FrameworksMoment` type.+* Depend on the [pqueue][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC.++  [#79]: https://github.com/HeinrichApfelmus/reactive-banana/issues/79++**version 0.8.1.2**++* Depend on the [psqueues][] package instead of the [pqueue][] package for the priority queue.++  [psqueues]: https://hackage.haskell.org/package/psqueues+  [pqueue]: http://hackage.haskell.org/package/pqueue++**version 0.8.1.1**++* Links to the Haskell wiki now point to the `http://wiki.haskell.org` subdomain.++**version 0.8.1.0**++* Module `Reactive.Banana.Switch` now adheres to the "Functor Applicative Monad Proposal" proposal][amp-proposal].++  [amp-proposal]: https://wiki.haskell.org/Functor-Applicative-Monad_Proposal++**version 0.8.0.4**++* Just a re-upload. The previous archive was broken.++**version 0.8.0.3**++* Export the `Future` type.+* Restrict `containers` dependency to lower bound 0.5.++**version 0.8.0.2**++* Fix compilation issue with hiding `empty` from the module `Reactive.Banana.Prim.Order`.++**version 0.8.0.1**++* New examples `Counter.hs` and `Octave.hs`.+* Bump `transfomers` dependency.++**version 0.8.0.0**++* A new module `Reactive.Banana.Prim` exports primitive combinators that you can use to implement your own FRP library with a different API.+* The push-driven implementation in `Reactive.Banana.Prim` now has the performance characteristics of an actual push-driven implementation. Some work has gone into optimizing constant factors as well. However there is still no garbage collection for dynamically created events and behaviors.+* The `accumE` and `accumB` combinators evaluate their state to WHNF to avoid a space leak. (Fixes issue #52). On the other hand, `Behavior` values are evaluated on demanded, i.e. only when required by the apply combinator `<@>` or similar.+* Recursion between events and behaviors should now work as advertised. (Fixed issue #56).+* The deprecated `liftIONow` function has been removed.+* The type of the `changes` function now indicates that the new Behavior value is only available in the context of `reactimate`. A variant `reactimate'` makes this explicit.+* The module `Control.Event.Handler` now exports the `AddHandler` type, which is now a `newtype`. The module `Reactive.Banana.Frameworks.AddHandler` has been removed.++**version 0.7.1.0**++* Deprecate the `liftIONow` function in favor of `liftIO`.++**version 0.7.0.0**++* *Dynamic event switching*. Combinators are now available in the module `Reactive.Banana.Switch`.+* Rename `NetworkDescription` to `Moment`, add class constraint `Frameworks t`.+* No longer compiles with the JavaScript backend of the Utrecht Haskell compiler.+* Change the `changes` combinator to be less useful.++**version 0.6.0.0**++* Can now be compiled with the JavaScript backend of the Utrecht Haskell compiler.+* The push-driven implementations needs the `UseExtensions` flag to work. This flag is enabled by default.+* Minor module reorganization.++**version 0.5.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2012/03/25-frp-banana-0-5.html)++This update includes numerous changes, in particular a complete overhaul of the internal implementation. Here a partial list.++* Add `collect`, `spill` and `unionWith` combinators to deal with simultaneous events.+* Remove general `Monoid` instance for `Event` to simplify reasoning about simultaneous events.+* Add `initial` and `changes` combinators that allow you to observe updates to `Behavior`. Remove the `Reactive.Banana.Incremental` module.+* Rename most modules,+* Change type signatures: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type.++**version 0.4.3.1**++* Model implementation of `accumE` now has the intended semantics.++**version 0.4.3.0**++* Change semantics: `IO` actions from inside `reactimate` may now interleave as dictated by your event-based framework (issue #15).+* Fix bug: compiling a network twice no longer fails due to lingering global state (issue #16).+* Change type: remove `Typeable` constraint from `interpret` and `interpretAsHandler`.+* Misc: Remove the `BlackBoard` application from the repository.++**version 0.4.2.0**++* Change type: remove `Typeable` constraint from `fromAddHandler`.+* Misc: the `Vault` data type gets its own package.+* Misc: `reactive-banana-wx` now compiles properly with cabal.+* Add some more examples to the `reactive-banana-wx` package.++**version 0.4.1.0**++* Add `<@>` operator for more convenience when using `apply`.+* Add support for value recursion to the `NetworkDescription` monad.+* Add many examples to `reactive-banana-wx`.++**version 0.4.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/07/07-frp-banana-0-4.html)++* Add function `fromPoll` to obtain behaviors from mutable data.+* Change name: `run` is now called `actuate`.+* Add derived data type `Discrete`.+* Add function `interpretAsHandler`.++**version 0.3.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-3.html)++* change: event networks are now first-class values, you can `pause` or `run` them.+* change type: `AddHandler` now expects a way to unregister event handlers.+* add example `RunPause.hs`++**version 0.2.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-2.html)++* change: now implements proper semantics as pioneered by Conal Elliott+* model implementation for semantics+* push-driven implementation for efficiency+* add example `SlotMachine.hs`++**version 0.1.0.0**++* initial release
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, Heinrich Apfelmus+Copyright (c)2011-2015, Heinrich Apfelmus  All rights reserved.
+ benchmark/Main.hs view
@@ -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 []       = []
doc/examples/ActuatePause.hs view
@@ -71,7 +71,7 @@     ecounter <- fromAddHandler (addHandler escounter)     epause   <- fromAddHandler (addHandler espause  )     -    let ecount = accumE 0 ((+1) <$ ecounter)+    ecount <- accumE 0 $ (+1) <$ ecounter          reactimate $ fmap print ecount     reactimate $ fmap pause epause
+ doc/examples/Counter.hs view
@@ -0,0 +1,80 @@+{-----------------------------------------------------------------------------+    reactive-banana+    +    Example: Actuate and pause an event network acting as a counter+------------------------------------------------------------------------------}+import Control.Monad (when)+import System.IO++import Reactive.Banana+import Reactive.Banana.Frameworks+++main :: IO ()+main = do+    displayHelpMessage+    sources <- (,,) <$> newAddHandler <*> newAddHandler <*> newAddHandler+    network <- setupNetwork sources+    actuate network+    eventLoop sources network++displayHelpMessage :: IO ()+displayHelpMessage = mapM_ putStrLn $+    "Commands are:":+    "   +   - increase counterUp event":+    "   -   - decrease counterUp event":+    "   p   - pause event network":+    "   a   - actuate event network":+    "   q   - quit the program":+    "":+    []++-- Read commands and fire corresponding events +eventLoop :: (EventSource (), EventSource (),EventSource EventNetwork) -> EventNetwork -> IO ()+eventLoop (eplus, eminus, espause) network = loop+    where+    loop = do+        putStr "> "+        hFlush stdout+        hSetBuffering stdin NoBuffering+        s <- getChar+        case s of+            '+'   -> fire eplus ()+            '-'   -> fire eminus ()+            'p'   -> fire espause network+            'a'   -> actuate network+            'q'   -> return ()+            _     -> putStrLn $ [s] ++ " - unknown command"+        when (s /= 'q') loop++{-----------------------------------------------------------------------------+    Event sources+------------------------------------------------------------------------------}+-- Event Sources - allows you to register event handlers+-- Your GUI framework should provide something like this for you+type EventSource a = (AddHandler a, a -> IO ())++addHandler :: EventSource a -> AddHandler a+addHandler = fst++fire :: EventSource a -> a -> IO ()+fire = snd++{-----------------------------------------------------------------------------+    Program logic+------------------------------------------------------------------------------}+-- Set up the program logic in terms of events and behaviors.+setupNetwork :: (EventSource (), EventSource (), EventSource EventNetwork) -> IO EventNetwork+setupNetwork (eplus, eminus, espause) = compile $ do+    counterUp   <- fromAddHandler (addHandler eplus)+    counterDown <- fromAddHandler (addHandler eminus)+    epause      <- fromAddHandler (addHandler espause)++    ecount <- accumE 0 $ unions+        [ (+1)       <$ counterUp+        , subtract 1 <$ counterDown+        ]++    reactimate $ fmap print ecount+    reactimate $ fmap pause epause+
+ doc/examples/Octave.hs view
@@ -0,0 +1,88 @@+{-----------------------------------------------------------------------------+    reactive-banana++    Example: "The world's worst synthesizer"+    from the unofficial tutorial.+    <http://wiki.haskell.org/FRP_explanation_using_reactive-banana>+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+    -- allows recursive do notation+    -- mdo+    --     ...++module Main where++import Data.Char     (toUpper)+import Control.Monad (forever)+import System.IO     (BufferMode(..), hSetEcho, hSetBuffering, stdin)++import Reactive.Banana+import Reactive.Banana.Frameworks+++type Octave = Int++data Pitch = PA | PB | PC | PD | PE | PF | PG+    deriving (Eq, Enum)++-- Mapping between pitch and the char responsible for it.+pitchChars :: [(Pitch, Char)]+pitchChars = [(p, toEnum $ fromEnum 'a' + fromEnum p) |+              p <- [PA .. PG]]++-- Reverse of pitchChars+charPitches :: [(Char, Pitch)]+charPitches = [(b, a) | (a, b) <- pitchChars]++data Note = Note Octave Pitch++instance Show Pitch where+    show p = case lookup p pitchChars of+        Nothing -> error "cannot happen"+        Just c  -> [toUpper c]++instance Show Note where+    show (Note o p) = show p ++ show o++-- Filter and transform events at the same time.+filterMapJust :: (a -> Maybe b) -> Event a -> Event b+filterMapJust f = filterJust . fmap f++-- Change the original octave by adding a number of octaves, taking+-- care to limit the resulting octave to the 0..10 range.+changeOctave :: Int -> Octave -> Octave+changeOctave d = max 0 . min 10 . (d+)++-- Get the octave change for the '+' and '-' chars.+getOctaveChange :: Char -> Maybe Int+getOctaveChange c = case c of+    '+' -> Just 1+    '-' -> Just (-1)+    _ -> Nothing++makeNetworkDescription :: AddHandler Char -> MomentIO ()+makeNetworkDescription addKeyEvent = do+    eKey <- fromAddHandler addKeyEvent++    let eOctaveChange = filterMapJust getOctaveChange eKey+    bOctave <- accumB 3 (changeOctave <$> eOctaveChange)++    let ePitch = filterMapJust (`lookup` charPitches) eKey+    bPitch <- stepper PC ePitch++    let+        bNote = Note <$> bOctave <*> bPitch+        foo = Note 0 PA++    eNoteChanged <- changes bNote+    reactimate' $ fmap (\n -> putStrLn ("Now playing " ++ show n))+                 <$> eNoteChanged++main :: IO ()+main = do+    (addKeyEvent, fireKey) <- newAddHandler+    network <- compile (makeNetworkDescription addKeyEvent)+    actuate network+    hSetEcho stdin False+    hSetBuffering stdin NoBuffering+    forever (getChar >>= fireKey)
doc/examples/SlotMachine.hs view
@@ -3,7 +3,14 @@          Example: Slot machine ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+{-# LANGUAGE ScopedTypeVariables #-}+    -- allows pattern signatures like+    -- do+    --     (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+    -- allows recursive do notation+    -- mdo+    --     ...  import Control.Monad (when) import Data.Maybe (isJust, fromJust)@@ -21,7 +28,7 @@ main = do     displayHelpMessage     sources <- makeSources-    network <- compile $ setupNetwork sources+    network <- compile $ networkDescription sources     actuate network     eventLoop sources @@ -78,37 +85,30 @@ -- A win consist of either double or triple numbers data Win = Double | Triple --- payout for each win-payout :: Win -> Money-payout Double = 20-payout Triple = 200 ---- Set up the program logic in terms of events and behaviors.-setupNetwork :: forall t. Frameworks t => -    (EventSource (), EventSource ()) -> Moment t ()-setupNetwork (escoin,esplay) = do+-- Program logic in terms of events and behaviors.+networkDescription :: (EventSource (), EventSource ()) -> MomentIO ()+networkDescription (escoin,esplay) = mdo     -- initial random number generator-    initialStdGen <- liftIONow $ newStdGen+    initialStdGen <- liftIO $ newStdGen      -- Obtain events corresponding to the  coin  and  play  commands     ecoin <- fromAddHandler (addHandler escoin)     eplay <- fromAddHandler (addHandler esplay)     -    let         -        -- The state of the slot machine is captured in Behaviors.-            -        -- State: credits that the player has to play the game-        -- The  ecoin      event adds a coin to the credits-        -- The  edoesplay  event removes money-        -- The  ewin       event adds credits because the player has won-        bcredits :: Behavior t Money-        ecredits :: Event t Money-        (ecredits, bcredits) = mapAccum 0 . fmap (\f x -> (f x,f x)) $-            ((addCredit <$ ecoin)-            `union` (removeCredit <$ edoesplay)-            `union` (addWin <$> ewin))+    -- The state of the slot machine is captured in Behaviors.         +    -- State: credits that the player has to play the game+    -- The  ecoin      event adds a coin to the credits+    -- The  edoesplay  event removes money+    -- The  ewin       event adds credits because the player has won+    (ecredits :: Event Money, bcredits :: Behavior Money)+        <- mapAccum 0 . fmap (\f x -> (f x,f x)) $ unions $+            [ addCredit    <$ ecoin+            , removeCredit <$ edoesplay+            , addWin       <$> ewin+            ]+    let         -- functions that change the accumulated state         addCredit     = (+1)         removeCredit  = subtract 1@@ -116,34 +116,34 @@         addWin Triple = (+20)                  -- Event: does the player have enough money to play the game?-        emayplay :: Event t Bool-        emayplay = apply ((\credits _ -> credits > 0) <$> bcredits) eplay+        emayplay :: Event Bool+        emayplay = (\credits _ -> credits > 0) <$> bcredits <@> eplay                  -- Event: player has enough coins and plays-        edoesplay :: Event t ()+        edoesplay :: Event ()         edoesplay = () <$ filterE id  emayplay         -- Event: event that fires when the player doesn't have enough money-        edenied   :: Event t ()+        edenied   :: Event ()         edenied   = () <$ filterE not emayplay                  -        -- State: random number generator-        bstdgen :: Behavior t StdGen-        eroll   :: Event t Reels+    -- State: random number generator+    (eroll :: Event Reels, bstdgen :: Behavior StdGen)         -- accumulate the random number generator while rolling the reels-        (eroll, bstdgen) = mapAccum initialStdGen (roll <$> edoesplay)-        +        <- mapAccum initialStdGen $ roll <$> edoesplay++    let         -- roll the reels         roll :: () -> StdGen -> (Reels, StdGen)         roll () gen0 = ((z1,z2,z3),gen3)             where-            random = randomR(1,4)+            random    = randomR(1,4)             (z1,gen1) = random gen0             (z2,gen2) = random gen1             (z3,gen3) = random gen2                  -- Event: it's a win!-        ewin :: Event t Win+        ewin :: Event Win         ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll         checkWin (z1,z2,z3)             | length (nub [z1,z2,z3]) == 1 = Just Triple@@ -151,6 +151,7 @@             | otherwise                    = Nothing  +    -- ecredits <- changes bcredits     reactimate $ putStrLn . showCredit <$> ecredits     reactimate $ putStrLn . showRoll   <$> eroll     reactimate $ putStrLn . showWin    <$> ewin@@ -161,6 +162,3 @@ showRoll (z1,z2,z3) = "You rolled  " ++ show z1 ++ show z2 ++ show z3 showWin Double = "Wow, a double!" showWin Triple = "Wowwowow! A triple! So awesome!"---
+ doc/frp-behavior.png view

binary file changed (absent → 18670 bytes)

+ doc/frp-event.png view

binary file changed (absent → 15200 bytes)

+ doc/frp-stepper.png view

binary file changed (absent → 20782 bytes)

reactive-banana.cabal view
@@ -1,98 +1,143 @@ Name:                reactive-banana-Version:             0.7.1.3-Synopsis:            Practical library for functional reactive programming (FRP).-Description:         -    Reactive-banana is a practical library for Functional Reactive Programming (FRP).+Version:             1.3.2.0+Synopsis:            Library for functional reactive programming (FRP).+Description:+    Reactive-banana is a library for Functional Reactive Programming (FRP).     .-    FRP offers an elegant and concise way to express interactive programs such as graphical user interfaces, animations, computer music or robot controllers. Thus, the reactive-banana library promises to avoid the spaghetti code commonly used in traditional GUI technologies.+    FRP offers an elegant and concise way to express interactive programs such as graphical user interfaces, animations, computer music or robot controllers. It promises to avoid the spaghetti code that is all too common in traditional approaches to GUI programming.     .-    See the project homepage <http://haskell.org/haskellwiki/Reactive-banana>-    for a more detailed introduction and features.+    See the project homepage <http://wiki.haskell.org/Reactive-banana>+    for more detailed documentation and examples.     .-    Stability forecast:-    No semantic bugs expected.-    Significant API changes are likely in future versions,-    though the main interface is beginning to stabilize.-    The @Reactive.Banana.Switch@ module is quite experimental.-    There is currently /no/ garbage collection for dynamically created events.+    /Stability forecast./+    This is a stable library, though minor API changes are still likely.+    It features an efficient, push-driven implementation+    and has seen some optimization work.+    .+    /API guide./+    Start with the "Reactive.Banana" module. -Homepage:            http://haskell.org/haskellwiki/Reactive-banana+Homepage:            http://wiki.haskell.org/Reactive-banana License:             BSD3 License-file:        LICENSE Author:              Heinrich Apfelmus Maintainer:          Heinrich Apfelmus <apfelmus quantentunnel de>-Stability:           Experimental Category:            FRP-Cabal-version:       >= 1.9.2+Cabal-version:       1.18 Build-type:          Simple+Tested-with:         GHC == 9.4.1+                   , GHC == 9.2.4+                   , GHC == 8.10.7+                   , GHC == 8.8.4+                   , GHC == 8.6.5+                   , GHC == 8.4.4 -extra-source-files:     doc/examples/*.hs,-                        src/Reactive/Banana/Test.hs-                        src/Reactive/Banana/Test/Plumbing.hs+extra-source-files:     CHANGELOG.md,+                        doc/examples/*.hs+extra-doc-files:        doc/*.png  Source-repository head     type:               git-    location:           git://github.com/HeinrichApfelmus/reactive-banana.git+    location:           https://github.com/HeinrichApfelmus/reactive-banana     subdir:             reactive-banana/ -flag UseExtensions-    description: Use GHC-specific language extensions.-                 This enables the efficient push-driven implementation,-                 but doesn't necessarily work with compilers other than GHC.--- Cabal checks if the package can be build with  UseExtensions = True,--- otherewise it is set to  False .- Library+    default-language:   Haskell98     hs-source-dirs:     src-    -    extensions:         RecursiveDo,-                        Rank2Types, ScopedTypeVariables,-                        ExistentialQuantification,-                        TypeSynonymInstances, FlexibleInstances,-                        NoMonomorphismRestriction-    -    build-depends:      base >= 4.2 && < 5,-                        containers >= 0.3 && < 0.6,-                        transformers >= 0.2 && < 0.4,-                        vault == 0.3.* -    extensions:         EmptyDataDecls,-                        BangPatterns--    build-depends:      unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.3+    build-depends:      base >= 4.2 && < 5,+                        deepseq >= 1.4.3.0 && < 1.5,+                        semigroups >= 0.13 && < 0.21,+                        containers >= 0.5 && < 0.7,+                        transformers >= 0.2 && < 0.7,+                        vault == 0.3.*,+                        unordered-containers >= 0.2.1.0 && < 0.3,+                        hashable >= 1.1 && < 1.5,+                        pqueue >= 1.0 && < 1.5,+                        stm >= 2.5 && < 2.6,+                        these >= 0.2 && < 1.2 ---      CPP-options:    -DUseExtensions-             exposed-modules:+                        Control.Event.Handler,                         Reactive.Banana,                         Reactive.Banana.Combinators,-                        Reactive.Banana.Experimental.Calm,                         Reactive.Banana.Frameworks,-                        Reactive.Banana.Frameworks.AddHandler,-                        Reactive.Banana.Model-                        Reactive.Banana.Switch-    +                        Reactive.Banana.Model,+                        Reactive.Banana.Prim.Mid,+                        Reactive.Banana.Prim.High.Cached,+                        Reactive.Banana.Prim.Low.Graph,+                        Reactive.Banana.Prim.Low.GraphGC,+                        Reactive.Banana.Prim.Low.Ref+     other-modules:-                        Reactive.Banana.Internal.Cached,-                        Reactive.Banana.Internal.DependencyGraph,-                        Reactive.Banana.Internal.EventBehavior1,-                        Reactive.Banana.Internal.InputOutput-                        Reactive.Banana.Internal.Phantom,-                        Reactive.Banana.Internal.PulseLatch0,-                        Reactive.Banana.Internal.Types2+                        Control.Monad.Trans.ReaderWriterIO,+                        Control.Monad.Trans.RWSIO,+                        Reactive.Banana.Prim.Low.OrderedBag,+                        Reactive.Banana.Prim.Low.GraphTraversal,+                        Reactive.Banana.Prim.Mid.Combinators,+                        Reactive.Banana.Prim.Mid.Compile,+                        Reactive.Banana.Prim.Mid.Evaluation,+                        Reactive.Banana.Prim.Mid.IO,+                        Reactive.Banana.Prim.Mid.Plumbing,+                        Reactive.Banana.Prim.Mid.Test,+                        Reactive.Banana.Prim.Mid.Types,+                        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 --- compiling the test suite from cabal currently doesn't work-Test-Suite tests+Test-Suite unit+    default-language:   Haskell98     type:               exitcode-stdio-1.0-    hs-source-dirs:     src-    main-is:            Reactive/Banana/Test.hs-    build-depends:      base >= 4.2 && < 5,-                        HUnit >= 1.2 && < 2,-                        test-framework >= 0.6 && < 0.9,-                        test-framework-hunit >= 0.2 && < 0.4,-                        reactive-banana, vault, containers, transformers,-                        unordered-containers, hashable+    hs-source-dirs:     test+    main-is:            reactive-banana-tests.hs+    other-modules:      Reactive.Banana.Test.High.Combinators,+                        Reactive.Banana.Test.High.Plumbing,+                        Reactive.Banana.Test.High.Space,+                        Reactive.Banana.Test.Mid.Space,+                        Reactive.Banana.Test.Low.Gen,+                        Reactive.Banana.Test.Low.Graph,+                        Reactive.Banana.Test.Low.GraphGC+    build-depends:      base >= 4.7 && < 5,+                        containers,+                        deepseq >= 1.4.3.0 && < 1.5,+                        hashable,+                        pqueue,+                        reactive-banana,+                        semigroups,+                        transformers,+                        tasty,+                        tasty-hunit,+                        tasty-quickcheck >= 0.10.1.2 && < 0.11,+                        QuickCheck >= 2.10 && < 2.15,+                        unordered-containers,+                        vault,+                        these +Benchmark space+  default-language:     Haskell2010+  type:                 exitcode-stdio-1.0+  build-depends:        base+                      , reactive-banana+                      , tasty-quickcheck+                      , tasty+                      , QuickCheck+  hs-source-dirs:       test+  main-is:              space.hs+  other-modules:        Reactive.Banana.Test.Mid.Space+                      , Reactive.Banana.Test.High.Space+  ghc-options:        -rtsopts -eventlog ++Benchmark benchmark+  default-language:     Haskell2010+  type:                 exitcode-stdio-1.0+  build-depends:        base+                      , reactive-banana+                      , containers+                      , random+                      , tasty+                      , tasty-bench+  hs-source-dirs:       benchmark+  main-is:              Main.hs+  ghc-options:          "-with-rtsopts=-A32m"
+ src/Control/Event/Handler.hs view
@@ -0,0 +1,95 @@+module Control.Event.Handler (+    -- * Synopsis+    -- | <http://en.wikipedia.org/wiki/Event-driven_programming Event-driven programming>+    -- in the traditional imperative style.++    -- * Documentation+    Handler, AddHandler(..), newAddHandler,+    mapIO, filterIO,+    ) where+++import           Control.Monad ((>=>), when)+import           Data.IORef+import qualified Data.Map    as Map+import qualified Data.Unique++{-----------------------------------------------------------------------------+    Types+------------------------------------------------------------------------------}+-- | An /event handler/ is a function that takes an+-- /event value/ and performs some computation.+type Handler a = a -> IO ()++-- | The type 'AddHandler' represents a facility for registering+-- event handlers. These will be called whenever the event occurs.+--+-- When registering an event handler, you will also be given an action+-- that unregisters this handler again.+--+-- > do unregisterMyHandler <- register addHandler myHandler+--+newtype AddHandler a = AddHandler { register :: Handler a -> IO (IO ()) }++{-----------------------------------------------------------------------------+    Combinators+------------------------------------------------------------------------------}+instance Functor AddHandler where+    fmap f = mapIO (return . f)++-- | Map the event value with an 'IO' action.+mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b+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 -> when b $ h x++{-----------------------------------------------------------------------------+    Construction+------------------------------------------------------------------------------}+-- | Build a facility to register and unregister event handlers.+-- Also yields a function that takes an event handler and runs all the registered+-- handlers.+--+-- Example:+--+-- > do+-- >     (addHandler, fire) <- newAddHandler+-- >     register addHandler putStrLn+-- >     fire "Hello!"+newAddHandler :: IO (AddHandler a, Handler a)+newAddHandler = do+    handlers <- newIORef Map.empty+    let register handler = do+            key <- Data.Unique.newUnique+            atomicModifyIORef_ handlers $ Map.insert key handler+            return $ atomicModifyIORef_ handlers $ Map.delete key+        runHandlers a =+            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
+ src/Control/Monad/Trans/RWSIO.hs view
@@ -0,0 +1,87 @@+module Control.Monad.Trans.RWSIO (+    -- * Synopsis+    -- | An implementation of the reader/writer/state monad transformer+    -- using an 'IORef'.++    -- * Documentation+    RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put,+    ) where++import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.IORef++{-----------------------------------------------------------------------------+    Type and class instances+------------------------------------------------------------------------------}+data Tuple r w s = Tuple !r !(IORef w) !(IORef s)++newtype RWSIOT r w s m a = R { run :: Tuple r w s -> m a }++instance Functor m => Functor (RWSIOT r w s m) where fmap = fmapR++instance Applicative m => Applicative (RWSIOT r w s m) where+    pure  = pureR+    (<*>) = apR++instance Monad m => Monad (RWSIOT r w s m) where+    (>>=)  = bindR++instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR+instance MonadIO m => MonadIO (RWSIOT r w s m)   where liftIO = liftIOR+instance MonadTrans (RWSIOT r w s)               where lift = liftR++{-----------------------------------------------------------------------------+    Functions+------------------------------------------------------------------------------}+liftIOR :: MonadIO m => IO a -> RWSIOT r w s m a+liftIOR m = R $ \_ -> liftIO m++liftR :: m a -> RWSIOT r w s m a+liftR   m = R $ \_ -> m++fmapR :: Functor m => (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b+fmapR f m = R $ \x -> fmap f (run m x)++bindR :: Monad m => RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b+bindR m k = R $ \x -> run m x >>= \a -> run (k a) x++mfixR :: MonadFix m => (a -> RWSIOT r w s m a) -> RWSIOT r w s m a+mfixR f   = R $ \x -> mfix (\a -> run (f a) x)++pureR :: Applicative m => a -> RWSIOT r w s m a+pureR a   = R $ \_ -> pure a++apR :: Applicative m => RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b+apR f a   = R $ \x -> run f x <*> run a x++rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a+rwsT f = do+    r <- ask+    s <- get+    (a,s,w) <- liftIOR $ f r s+    put  s+    tell w+    return a++runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w))+runRWSIOT m r s = do+    w' <- liftIO $ newIORef mempty+    s' <- liftIO $ newIORef s+    a  <- run m (Tuple r w' s')+    s  <- liftIO $ readIORef s'+    w  <- liftIO $ readIORef w'+    return (a,s,w)++tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m ()+tell w = R $ \(Tuple _ w' _) -> liftIO $ modifyIORef w' (`mappend` w)++ask :: Monad m => RWSIOT r w s m r+ask = R $ \(Tuple r _ _) -> return r++get :: MonadIO m => RWSIOT r w s m s+get = R $ \(Tuple _ _ s') -> liftIO $ readIORef s'++put :: MonadIO m => s -> RWSIOT r w s m ()+put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s
+ src/Control/Monad/Trans/ReaderWriterIO.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeFamilies #-}+module Control.Monad.Trans.ReaderWriterIO (+    -- * Synopsis+    -- | An implementation of the reader/writer monad transformer+    -- using an 'IORef' for the writer.++    -- * Documentation+    ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local,+    ) where++import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.IORef++{-----------------------------------------------------------------------------+    Type and class instances+------------------------------------------------------------------------------}+newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a }++instance Functor m => Functor (ReaderWriterIOT r w m)   where fmap = fmapR++instance Applicative m => Applicative (ReaderWriterIOT r w m) where+    pure  = pureR+    (<*>) = apR++instance Monad m => Monad (ReaderWriterIOT r w m) where+    (>>=)  = bindR++instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR+instance MonadIO m => MonadIO (ReaderWriterIOT r w m)   where liftIO = liftIOR+instance MonadTrans (ReaderWriterIOT r w)               where lift = liftR++instance (Monad m, a ~ ()) => Semigroup (ReaderWriterIOT r w m a) where+    mx <> my = mx >> my++instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where+    mempty  = return ()+    mappend = (<>)++{-----------------------------------------------------------------------------+    Functions+------------------------------------------------------------------------------}+liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a+liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m++liftR :: m a -> ReaderWriterIOT r w m a+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)++bindR :: Monad m => ReaderWriterIOT r w m a -> (a -> ReaderWriterIOT r w m b) -> ReaderWriterIOT r w m b+bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y++mfixR :: MonadFix m => (a -> ReaderWriterIOT r w m a) -> ReaderWriterIOT r w m a+mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y)++pureR :: Applicative m => a -> ReaderWriterIOT r w m a+pureR a = ReaderWriterIOT $ \_ _ -> pure a++apR :: Applicative m => ReaderWriterIOT r w m (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b+apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y++readerWriterIOT :: (MonadIO m, Monoid w) =>+    (r -> IO (a, w)) -> ReaderWriterIOT r w m a+readerWriterIOT f = do+    r <- ask+    (a,w) <- liftIOR $ f r+    tell w+    return a++runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w)+runReaderWriterIOT m r = do+    ref <- liftIO $ newIORef mempty+    a   <- run m r ref+    w   <- liftIO $ readIORef ref+    return (a,w)++tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m ()+tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w)++listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w)+listen m = ReaderWriterIOT $ \r ref -> do+    a <- run m r ref+    w <- liftIO $ readIORef ref+    return (a,w)++local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a+local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref++ask :: Monad m => ReaderWriterIOT r w m r+ask = ReaderWriterIOT $ \r _ -> return r
src/Reactive/Banana.hs view
@@ -1,16 +1,43 @@ {------------------------------------------------------------------------------    Reactive Banana--    A small library for functional reactive programming.+    reactive-banana ------------------------------------------------------------------------------}  module Reactive.Banana (+    -- * Synopsis+    -- | Reactive-banana is a library for functional reactive programming (FRP).+    -- To use it, import this module:+    --+    -- > import Reactive.Banana++    -- * Overview+    -- $intro++    -- * Exports     module Reactive.Banana.Combinators,-    module Reactive.Banana.Switch,     compile,     ) where  import Reactive.Banana.Combinators import Reactive.Banana.Frameworks-import Reactive.Banana.Internal.Types2-import Reactive.Banana.Switch++{-$intro++The module "Reactive.Banana.Combinators" collects the key types+and concepts of FRP. You will spend most of your time with this module.++The module "Reactive.Banana.Model" is /not/ used in practice.+It contains an easy-to-understand model re-implementation of the FRP API.+This is useful for learning FRP and for internal testing purposes.++The module "Reactive.Banana.Frameworks" allows you to connect+the FRP types and combinators to the outside world (IO).+If you are /using/ an existing binding like reactive-banana-wx,+then you probably won't need this module very often.+On the other hand, if you are /writing/ a binding to an external+library, then you will definitely need this.++The module hierarchy at "Reactive.Banana.Prim"+implements the efficient low-level FRP engine that powers the rest of the library.+This is only useful if you want to implement your own FRP library.++-}
src/Reactive/Banana/Combinators.hs view
@@ -2,329 +2,404 @@     reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Reactive.Banana.Combinators (     -- * Synopsis-    -- | Combinators for building event graphs.-    -    -- * Introduction-    -- $intro1+    -- $synopsis++    -- * Core Combinators+    -- ** Event and Behavior     Event, Behavior,-    -- $intro2     interpret,-    -    -- * Core Combinators++    -- ** First-order+    -- | This subsections lists the primitive first-order combinators for FRP.+    -- The 'Functor', 'Applicative' and 'Monoid' instances are also part of this,+    -- but they are documented at the types 'Event' and 'Behavior'.     module Control.Applicative,-    module Data.Monoid,-    never, union, unions, filterE, collect, spill, accumE,-    apply, stepper,-    -- $classes-    +    module Data.Semigroup,+    never, unionWith, filterE,+    apply,++    -- ** Moment and accumulation+    Moment, MonadMoment(..),+    accumE, stepper,++    -- ** Recursion+    -- $recursion++    -- ** Higher-order+    valueB, valueBLater, observeE, switchE, switchB,+     -- * Derived Combinators+    -- ** Infix operators+    (<@>), (<@), (@>),     -- ** Filtering-    filterJust, filterApply, whenE, split,+    filterJust, filterApply, whenE, split, once,     -- ** Accumulation     -- $Accumulation.-    accumB, mapAccum,-    -- ** Simultaneous event occurrences-    calm, unionWith,-    -- ** Apply class-    Apply(..),+    unions, accumB, mapAccum,+    -- ** Merging events+    merge, mergeWith     ) where  import Control.Applicative-import Control.Monad--import Data.Maybe (isJust, catMaybes)-import Data.Monoid (Monoid(..))---import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2 +import Data.Semigroup+import Data.These (These(..)) +import qualified Reactive.Banana.Prim.High.Combinators as Prim+import           Reactive.Banana.Types  {-----------------------------------------------------------------------------     Introduction ------------------------------------------------------------------------------}-{-$intro1+{-$synopsis -At its core, Functional Reactive Programming (FRP) is about two-data types 'Event' and 'Behavior' and the various ways to combine them.+The main types and combinators of Functional Reactive Programming (FRP). +At its core, FRP is about two data types 'Event' and 'Behavior'+and the various ways to combine them.+There is also a third type 'Moment',+which is necessary for the higher-order combinators.+ -}  -- Event -- Behavior -{-$intro2--As you can see, both types seem to have a superfluous parameter @t@.-The library uses it to rule out certain gross inefficiencies,-in particular in connection with dynamic event switching.-For basic stuff, you can completely ignore it,-except of course for the fact that it will annoy you in your type signatures.--While the type synonyms mentioned above are the way you should think about-'Behavior' and 'Event', they are a bit vague for formal manipulation.-To remedy this, the library provides a very simple but authoritative-model implementation. See "Reactive.Banana.Model" for more.---}- {-----------------------------------------------------------------------------     Interpetation ------------------------------------------------------------------------------} -- | Interpret an event processing function. -- Useful for testing.-interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]-interpret f xs =-    map toList <$> Prim.interpret (return . unE . f . E) (map Just xs)---toList :: Maybe [a] -> [a]-toList Nothing   = []-toList (Just xs) = xs+--+-- Note: You can safely assume that this function is pure,+-- even though the type seems to suggest otherwise.+-- I'm really sorry about the extra 'IO', but it can't be helped.+-- See source code for the sordid details.+interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs+-- FIXME: I would love to remove the 'IO' from the type signature,+-- but unfortunately, it is possible that the argument to interpret+-- returns an Event that was created in the context of an existing network, e.g.+--+-- >   eBad <- fromAddHandler ...+-- >   ...+-- >   let ys = interpret (\_ -> return eBad ) xs+--+-- Doing this is a big no-no and will break a lot of things,+-- but if we remove the 'IO' here, then we will also break referential+-- transparency, and I think that takes it too far.  {-----------------------------------------------------------------------------     Core combinators ------------------------------------------------------------------------------}-singleton :: a -> [a]-singleton x = [x]- -- | Event that never occurs.--- Think of it as @never = []@.-never    :: Event t a-never = E $ Prim.mapE singleton Prim.never+-- Semantically,+--+-- > never = []+never    :: Event a+never = E Prim.never  -- | Merge two event streams of the same type.--- In case of simultaneous occurrences, the left argument comes first.--- Think of it as+-- The function argument specifies how event values are to be combined+-- in case of a simultaneous occurrence. The semantics are ----- > union ((timex,x):xs) ((timey,y):ys)--- >    | timex <= timey = (timex,x) : union xs ((timey,y):ys)--- >    | timex >  timey = (timey,y) : union ((timex,x):xs) ys-union    :: Event t a -> Event t a -> Event t a-union e1 e2 = E $ Prim.unionWith (++) (unE e1) (unE e2)+-- > unionWith f ((timex,x):xs) ((timey,y):ys)+-- >    | timex <  timey = (timex,x)     : unionWith f xs ((timey,y):ys)+-- >    | timex >  timey = (timey,y)     : unionWith f ((timex,x):xs) ys+-- >    | timex == timey = (timex,f x y) : unionWith f xs ys+unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a+unionWith f = mergeWith id id f --- | Merge several event streams of the same type.--- --- > unions = foldr union never-unions :: [Event t a] -> Event t a-unions = foldr union never+-- | Merge two event streams of any type.+merge :: Event a -> Event b -> Event (These a b)+merge = mergeWith This That These +-- | Merge two event streams of any type.+--+-- This function generalizes 'unionWith'.+mergeWith+  :: (a -> c) -- ^ The function called when only the first event emits a value.+  -> (b -> c) -- ^ The function called when only the second event emits a value.+  -> (a -> b -> c) -- ^ The function called when both events emit values simultaneously.+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h e1 e2 = E $ Prim.mergeWith f g h (unE e1) (unE e2)+ -- | Allow all event occurrences that are 'Just' values, discard the rest. -- Variant of 'filterE'.-filterJust :: Event t (Maybe a) -> Event t a-filterJust = E . Prim.filterJust . Prim.mapE (decide . catMaybes) . unE-    where-    decide xs = if null xs then Nothing else Just xs+filterJust :: Event (Maybe a) -> Event a+filterJust = E . Prim.filterJust . unE  -- | Allow all events that fulfill the predicate, discard the rest.--- Think of it as--- +-- Semantically,+-- -- > filterE p es = [(time,a) | (time,a) <- es, p a]-filterE   :: (a -> Bool) -> Event t a -> Event t a+filterE   :: (a -> Bool) -> Event a -> Event a filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing) --- | Collect simultaneous event occurences.--- The result will never contain an empty list.--- Example:+-- | Apply a time-varying function to a stream of events.+-- Semantically, ----- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])]-collect   :: Event t a -> Event t [a]-collect e = E $ Prim.mapE singleton (unE e)+-- > apply bf ex = [(time, bf time x) | (time, x) <- ex]+--+-- This function is generally used in its infix variant '<@>'.+apply :: Behavior (a -> b) -> Event a -> Event b+apply bf ex = E $ Prim.applyE (unB bf) (unE ex) --- | Emit simultaneous event occurrences.--- The first element in the list will be emitted first, and so on.+-- | Construct a time-varying function from an initial value and+-- a stream of new values. The result will be a step function.+-- Semantically, ----- Up to strictness, we have+-- > stepper x0 ex = \time1 -> \time2 ->+-- >     last (x0 : [x | (timex,x) <- ex, time1 <= timex, timex < time2]) ----- > spill . collect = id-spill :: Event t [a] -> Event t a-spill e = E $ Prim.filterJust $ Prim.mapE (nonempty . concat) (unE e)-    where-    nonempty [] = Nothing-    nonempty xs = Just xs---- | Construct a time-varying function from an initial value and --- a stream of new values. Think of it as+-- Here is an illustration of the result Behavior at a particular time: ----- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time])--- --- Note that the smaller-than-sign in the comparision @timex < time@ means --- that the value of the behavior changes \"slightly after\"--- the event occurrences. This allows for recursive definitions.--- --- Also note that in the case of simultaneous occurrences,--- only the last one is kept.-stepper :: a -> Event t a -> Behavior t a-stepper x e = B $ Prim.stepperB x $ Prim.mapE last $ unE e+-- <<doc/frp-stepper.png>>+--+-- Note: The smaller-than-sign in the comparison @timex < time2@ means+-- that at time @time2 == timex@, the value of the Behavior will+-- still be the previous value.+-- In the illustration, this is indicated by the dots at the end+-- of each step.+-- This allows for recursive definitions.+-- See the discussion below for more on recursion.+stepper :: MonadMoment m => a -> Event a -> m (Behavior a)+stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE --- | The 'accumE' function accumulates a stream of events.+-- | The 'accumE' function accumulates a stream of event values,+-- similar to a /strict/ left scan, 'scanl''.+-- It starts with an initial value and emits a new value+-- whenever an event occurrence happens.+-- The new value is calculated by applying the function in the event+-- to the old value.+-- -- Example: -- -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))]--- >    = [(time1,"xy"),(time2,"xyz")]------ Note that the output events are simultaneous with the input events,--- there is no \"delay\" like in the case of 'accumB'.-accumE   :: a -> Event t (a -> a) -> Event t a-accumE acc = E . mapAccumE acc . Prim.mapE concatenate . unE-    where-    concatenate :: [a -> a] -> a -> ([a],a)-    concatenate fs acc = (tail values, last values)-        where values = scanl' (flip ($)) acc fs--    mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a-    mapAccumE acc =-        Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd)---- strict version of scanl-scanl' :: (a -> b -> a) -> a -> [b] -> [a]-scanl' f x ys = x : case ys of-    []   -> []-    y:ys -> let z = f x y in z `seq` scanl' f z ys---- | Apply a time-varying function to a stream of events.--- Think of it as--- --- > apply bf ex = [(time, bf time x) | (time, x) <- ex]-apply    :: Behavior t (a -> b) -> Event t a -> Event t b-apply bf ex = E $ Prim.applyE (Prim.mapB map $ unB bf) (unE ex)+-- >     = trimE [(time1,"xy"),(time2,"xyz")]+-- >     where+-- >     trimE e start = [(time,x) | (time,x) <- e, start <= time]+accumE :: MonadMoment m => a -> Event (a -> a) -> m (Event a)+accumE acc = liftMoment . M . fmap E . Prim.accumE acc . unE -{-$classes+{-$recursion -/Further combinators that Haddock can't document properly./+/Recursion/ is a very important technique in FRP that is not apparent+from the type signatures. -> instance Monoid (Event t (a -> a))+Here is a prototypical example. It shows how the 'accumE' can be expressed+in terms of the 'stepper' and 'apply' functions by using recursion: -This monoid instance is /not/ the straightforward instance-that you would obtain from 'never' and 'union'.-Instead of just merging event streams, we use 'unionWith' to compose-the functions. This is very useful in the context of 'accumE' and 'accumB'-where simultaneous event occurrences are best avoided.+> accumE a e1 = mdo+>    let e2 = (\a f -> f a) <$> b <@> e1+>    b <- stepper a e2+>    return e2 -> instance Applicative (Behavior t)+(The @mdo@ notation refers to /value recursion/ in a monad.+The 'MonadFix' instance for the 'Moment' class enables this kind of recursive code.)+(Strictly speaking, this also means that 'accumE' is not a primitive,+because it can be expressed in terms of other combinators.) -'Behavior' is an applicative functor. In particular, we have the following functions.+This general pattern appears very often in practice:+A Behavior (here @b@) controls what value is put into an Event (here @e2@),+but at the same time, the Event contributes to changes in this Behavior.+Modeling this situation requires recursion. -> pure :: a -> Behavior t a+For another example, consider a vending machine that sells banana juice.+The amount that the customer still has to pay for a juice+is modeled by a Behavior @bAmount@.+Whenever the customer inserts a coin into the machine,+an Event @eCoin@ occurs, and the amount will be reduced.+Whenver the amount goes below zero, an Event @eSold@ will occur,+indicating the release of a bottle of fresh banana juice,+and the amount to be paid will be reset to the original price.+The model requires recursion, and can be expressed in code as follows: -The constant time-varying value. Think of it as @pure x = \\time -> x@.+> mdo+>     let price = 50 :: Int+>     bAmount  <- accumB price $ unions+>                   [ subtract 10 <$ eCoin+>                   , const price <$ eSold ]+>     let eSold = whenE ((<= 0) <$> bAmount) eCoin -> (<*>) :: Behavior t (a -> b) -> Behavior t a -> Behavior t b+On one hand, the Behavior @bAmount@ controls whether the Event @eSold@+occcurs at all; the bottle of banana juice is unavailable to penniless customers.+But at the same time, the Event @eSold@ will cause a reset+of the Behavior @bAmount@, so both depend on each other. -Combine behaviors in applicative style.-Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@.+Recursive code like this examples works thanks to the semantics of 'stepper'.+In general, /mutual recursion/ between several 'Event's and 'Behavior's+is always well-defined,+as long as an Event depends on itself only /via/ a Behavior,+and vice versa.  -} -{- No monoid instance, sorry.+-- | Obtain the value of the 'Behavior' at a given moment in time.+-- Semantically, it corresponds to+--+-- > valueB b = \time -> b time+--+-- Note: The value is immediately available for pattern matching.+-- Unfortunately, this means that @valueB@ is unsuitable for use+-- with value recursion in the 'Moment' monad.+-- If you need recursion, please use 'valueBLater' instead.+valueB :: MonadMoment m => Behavior a -> m a+valueB = liftMoment . M . Prim.valueB . unB -instance Monoid (Event t (a -> a)) where-    mempty  = never-    mappend = unionWith (flip (.))--}+-- | Obtain the value of the 'Behavior' at a given moment in time.+-- Semantically, it corresponds to+--+-- > valueBLater b = \time -> b time+--+-- Note: To allow for more recursion, the value is returned /lazily/+-- and not available for pattern matching immediately.+-- It can be used safely with most combinators like 'stepper'.+-- If that doesn't work for you, please use 'valueB' instead.+valueBLater :: MonadMoment m => Behavior a -> m a+valueBLater = liftMoment . M . Prim.initialBLater . unB -instance Functor (Event t) where-    fmap f e = E $ Prim.mapE (map f) (unE e) -instance Applicative (Behavior t) where-    pure x    = B $ Prim.pureB x-    bf <*> bx = B $ Prim.applyB (unB bf) (unB bx)+-- | Observe a value at those moments in time where+-- event occurrences happen. Semantically,+--+-- > observeE e = [(time, m time) | (time, m) <- e]+observeE :: Event (Moment a) -> Event a+observeE = E . Prim.observeE . Prim.mapE unM . unE -instance Functor (Behavior t) where-    fmap = liftA+-- | Dynamically switch between 'Event'.+-- Semantically,+--+-- > 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 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,+--+-- >  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+ {-----------------------------------------------------------------------------     Derived Combinators ------------------------------------------------------------------------------}-{-+infixl 4 <@>, <@, @> -Unfortunately, we can't make a  Num  instance because that would-require  Eq  and  Show .+-- | Infix synonym for the 'apply' combinator. Similar to '<*>'.+--+-- > infixl 4 <@>+(<@>) :: Behavior (a -> b) -> Event a -> Event b+(<@>) = apply -instance Num a => Num (Behavior t a) where-    (+) = liftA2 (+)-    (-) = liftA2 (-)-    (*) = liftA2 (*)-    negate = fmap negate-    abs    = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--}+-- | Tag all event occurrences with a time-varying value. Similar to '<*'.+--+-- > infixl 4 <@+(<@)  :: 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 t (a -> Bool) -> Event t a -> Event t a+filterApply :: Behavior (a -> Bool) -> Event a -> Event a filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp)  -- | Allow events only when the behavior is 'True'. -- Variant of 'filterApply'.-whenE :: Behavior t Bool -> Event t a -> Event t a+whenE :: Behavior Bool -> Event a -> Event a whenE bf = filterApply (const <$> bf)  -- | Split event occurrences according to a tag. -- The 'Left' values go into the left component while the 'Right' values -- go into the right component of the result.-split :: Event t (Either a b) -> (Event t a, Event t b)+split :: Event (Either a b) -> (Event a, Event b) split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e)     where+    fromLeft :: Either a b -> Maybe a     fromLeft  (Left  a) = Just a-    fromLeft  (Right b) = Nothing-    fromRight (Left  a) = Nothing+    fromLeft  (Right _) = Nothing++    fromRight :: Either a b -> Maybe b+    fromRight (Left  _) = Nothing     fromRight (Right b) = Just b  --- | Combine simultaneous event occurrences into a single occurrence.+-- | 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. ----- > unionWith f e1 e2 = fmap (foldr1 f) <$> collect (e1 `union` e2)-unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a-unionWith f e1 e2 = E $ Prim.unionWith g (unE e1) (unE e2)-    where g xs ys = singleton $ foldr1 f (xs ++ ys)---- | Keep only the last occurrence when simultaneous occurrences happen.-calm :: Event t a -> Event t a-calm = fmap last . collect-+-- > 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.--- Note: all accumulation functions are strict in the accumulated value!--- acc -> (x,acc) is the order used by 'unfoldr' and 'State'.+-- Note: All accumulation functions are strict in the accumulated value!+--+-- Note: The order of arguments is @acc -> (x,acc)@+-- which is also the convention used by 'unfoldr' and 'State'. --- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''.--- It starts with an initial value and combines it with incoming events.--- For example, think+-- | Merge event streams whose values are functions.+-- In case of simultaneous occurrences, the functions at the beginning+-- of the list are applied /after/ the functions at the end. --+-- > unions [] = never+-- > unions xs = foldr1 (unionWith (.)) xs+--+-- Very useful in conjunction with accumulation functions like 'accumB'+-- and 'accumE'.+unions :: [Event (a -> a)] -> Event (a -> a)+unions [] = never+unions xs = foldr1 (unionWith (.)) xs++-- | The 'accumB' function accumulates event occurrences into a 'Behavior'.+--+-- The value is accumulated using 'accumE' and converted+-- into a time-varying value using 'stepper'.+--+-- Example:+-- -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] -- >    = stepper "x" [(time1,"xy"),(time2,"xyz")]--- --- Note that the value of the behavior changes \"slightly after\"+--+-- Note: As with 'stepper', the value of the behavior changes \"slightly after\" -- the events occur. This allows for recursive definitions.-accumB   :: a -> Event t (a -> a) -> Behavior t a--- accumB x (Event e) = behavior $ AccumB x e-accumB  acc = stepper acc . accumE acc+accumB :: MonadMoment m => a -> Event (a -> a) -> m (Behavior a)+accumB acc e = stepper acc =<< accumE acc e  -- | Efficient combination of 'accumE' and 'accumB'.-mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc)-mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e))-    where e = accumE (undefined,acc) ((. snd) <$> ef)---infixl 4 <@>, <@---- | Class for overloading the 'apply' function.-class (Functor f, Functor g) => Apply f g where-    -- | Infix operation for the 'apply' function, similar to '<*>'-    (<@>) :: f (a -> b) -> g a -> g b-    -- | Convenience function, similar to '<*'-    (<@)  :: f a -> g b -> g a-    -    f <@ g = (const <$> f) <@> g --instance Apply (Behavior t) (Event t) where-    (<@>) = apply--+mapAccum :: MonadMoment m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc)+mapAccum acc ef = do+        e <- accumE  (undefined,acc) (lift <$> ef)+        b <- stepper acc (snd <$> e)+        return (fst <$> e, b)+    where+    lift f (_,acc) = acc `seq` f acc
− src/Reactive/Banana/Experimental/Calm.hs 
@@ -1,125 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, MultiParamTypeClasses,-    TypeSynonymInstances, FlexibleInstances #-}--module Reactive.Banana.Experimental.Calm (-    -- * Synopsis-    -- | Experimental module: API change very likely.-    ---    -- 'Event' type that disallows simultaneous event occurrences.-    ---    -- The combinators behave essentially as their counterparts-    -- in "Reactive.Banana.Combinators".-    -    -- * Main types-    Event, Behavior, collect, fromCalm,-    interpret,-    -    -- * Core Combinators-    module Control.Applicative,-    never, unionWith, filterE, accumE,-    apply, stepper,-    -    -- * Derived Combinators-    -- ** Filtering-    filterJust,-    -- ** Accumulation-    -- $Accumulation.-    accumB, mapAccum,-    -- ** Apply class-    Reactive.Banana.Combinators.Apply(..),-    ) where--import Control.Applicative-import Control.Monad--import Data.Maybe (listToMaybe)--import qualified Reactive.Banana.Combinators as Prim-import qualified Reactive.Banana.Combinators--{------------------------------------------------------------------------------    Main types-------------------------------------------------------------------------------}-newtype Event t a = E { unE :: Prim.Event t a }--type Behavior t = Reactive.Banana.Combinators.Behavior t---- | Convert event with possible simultaneous occurrences--- into an 'Event' with a single occurrence.-collect :: Reactive.Banana.Combinators.Event t a -> Event t [a]-collect = E . Prim.collect---- | Convert event with single occurrences into--- event with possible simultaneous occurrences-fromCalm :: Event t a -> Reactive.Banana.Combinators.Event t a-fromCalm = unE--singleton x = [x]---- | Interpretation function.--- Useful for testing.-interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b]-interpret f xs =-    map listToMaybe <$> Prim.interpret (unE . f . E) (map singleton xs)--{------------------------------------------------------------------------------    Core Combinators-------------------------------------------------------------------------------}--- | Event that never occurs.--- Think of it as @never = []@.-never    :: Event t a-never = E $ Prim.never---- | Merge two event streams of the same type.--- Combine simultaneous values if necessary.-unionWith    :: (a -> a -> a) -> Event t a -> Event t a -> Event t a-unionWith f e1 e2 = E $ Prim.unionWith f (unE e1) (unE e2)---- | Allow all events that fulfill the predicate, discard the rest.-filterE   :: (a -> Bool) -> Event t a -> Event t a-filterE p = E . Prim.filterE p . unE---- | Construct a time-varying function from an initial value and --- a stream of new values.-stepper :: a -> Event t a -> Behavior t a-stepper x e = Prim.stepper x (unE e)---- | The 'accumE' function accumulates a stream of events.-accumE   :: a -> Event t (a -> a) -> Event t a-accumE acc = E . Prim.accumE acc . unE---- | Apply a time-varying function to a stream of events.-apply    :: Behavior t (a -> b) -> Event t a -> Event t b-apply b = E . Prim.apply b . unE--instance Functor (Event t) where-    fmap f = E . fmap f . unE--{------------------------------------------------------------------------------    Derived Combinators-------------------------------------------------------------------------------}--- | Keep only the 'Just' values.--- Variant of 'filterE'.-filterJust :: Event t (Maybe a) -> Event t a-filterJust = E . Prim.filterJust . unE---- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''.--- It starts with an initial value and combines it with incoming events.-accumB :: a -> Event t (a -> a) -> Behavior t a-accumB acc = Prim.accumB acc . unE---- $Accumulation.--- Note: all accumulation functions are strict in the accumulated value!--- acc -> (x,acc) is the order used by 'unfoldr' and 'State'.---- | Efficient combination of 'accumE' and 'accumB'.-mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc)-mapAccum acc ef = let (e,b) = Prim.mapAccum acc (unE ef) in (E e, b)--instance Reactive.Banana.Combinators.Apply (Behavior t) (Event t) where-    (<@>) = apply--
src/Reactive/Banana/Frameworks.hs view
@@ -5,44 +5,47 @@  module Reactive.Banana.Frameworks (     -- * Synopsis-    -- | Build event networks using existing event-based frameworks-    -- and run them.-    +    -- | Connect to the outside world by building 'EventNetwork's+    -- and running them.+     -- * Simple use     interpretAsHandler, -    -- * Building event networks with input/output+    -- * Overview     -- $build-    compile, Frameworks,-    AddHandler, fromAddHandler, fromChanges, fromPoll,-    reactimate, initial, changes,-    FrameworksMoment(..), execute, liftIOLater, liftIONow,++    -- * Building event networks with input/output+    -- ** Core functions+    compile, MomentIO,+    module Control.Event.Handler,+    fromAddHandler, fromChanges, fromPoll,+    reactimate, Future, reactimate',+    changes,+    -- $changes+    imposeChanges,+    execute, liftIOLater,     -- $liftIO     module Control.Monad.IO.Class,-    ++    -- ** Utility functions+    -- | This section collects a few convience functions+    -- built from the core functions.+    interpretFrameworks, newEvent, mapEventIO, newBehavior,+     -- * Running event networks-    EventNetwork, actuate, pause,-    -    -- * Utilities-    -- $utilities-    newAddHandler, newEvent,-    module Reactive.Banana.Frameworks.AddHandler,-    -    -- * Internal-    interpretFrameworks,+    EventNetwork, actuate, pause, getSize,+     ) where -import Control.Monad-import Control.Monad.IO.Class-import Data.IORef+import           Control.Event.Handler+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.IORef+import           Reactive.Banana.Combinators+import qualified Reactive.Banana.Prim.High.Combinators as Prim+import           Reactive.Banana.Types -import Reactive.Banana.Combinators-import Reactive.Banana.Frameworks.AddHandler -import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2-import Reactive.Banana.Internal.Phantom- {-----------------------------------------------------------------------------     Documentation ------------------------------------------------------------------------------}@@ -59,29 +62,29 @@  * perform /output/ in reaction to events. -In constrast, the functions from "Reactive.Banana.Combinators" allow you +In contrast, the functions from "Reactive.Banana.Combinators" allow you to express the output events in terms of the input events. This expression is called an /event graph/.  An /event network/ is an event graph together with inputs and outputs. To build an event network, describe the inputs, outputs and event graph in the-'Moment' monad +'MomentIO' monad and use the 'compile' function to obtain an event network from that.  To /activate/ an event network, use the 'actuate' function.-The network will register its input event handlers and start +The network will register its input event handlers and start producing output.  A typical setup looks like this:-   + > main = do >   -- initialize your GUI framework >   window <- newWindow >   ... > >   -- describe the event network->   let networkDescription :: forall t. Frameworks t => Moment t ()+>   let networkDescription :: MomentIO () >       networkDescription = do >           -- input: obtain  Event  from functions that register event handlers >           emouse    <- fromAddHandler $ registerMouseEvent window@@ -92,12 +95,12 @@ >           bdie      <- fromPoll       $ randomRIO (1,6) > >           -- express event graph+>           behavior1 <- accumB ... >           let->               behavior1 = accumB ... >               ... >               event15 = union event13 event14->   ->           -- output: animate some event occurences+>+>           -- output: animate some event occurrences >           reactimate $ fmap print event15 >           reactimate $ fmap drawCircle eventCircle >@@ -113,24 +116,24 @@  * Use 'reactimate' to animate /output/ events. +* Use 'compile' to put everything together in an 'EventNetwork's+and use 'actuate' to start handling events.+ -}  {-----------------------------------------------------------------------------     Combinators ------------------------------------------------------------------------------}-singletonsE :: Prim.Event a -> Event t a-singletonsE = E . Prim.mapE (:[])- {- | Output. Execute the 'IO' action whenever the event occurs.   Note: If two events occur very close to each other,-there is no guarantee that the @reactimate@s for one +there is no guarantee that the @reactimate@s for one event will have finished before the ones for the next event start executing. This does /not/ affect the values of events and behaviors, it only means that the @reactimate@ for different events may interleave.-Fortuantely, this is a very rare occurrence, and only happens if+Fortunately, this is a very rare occurrence, and only happens if  * you call an event handler from inside 'reactimate', @@ -138,7 +141,7 @@  In these cases, the @reactimate@s follow the control flow of your event-based framework.-    + Note: An event network essentially behaves like a single, huge callback function. The 'IO' action are not run in a separate thread. The callback function will throw an exception if one of your 'IO' actions@@ -146,17 +149,26 @@ Your event-based framework will have to handle this situation.  -}-reactimate :: Frameworks t => Event t (IO ()) -> Moment t ()-reactimate = M . Prim.addReactimate . Prim.mapE sequence_ . unE+reactimate :: Event (IO ()) -> MomentIO ()+reactimate = MIO . Prim.addReactimate . Prim.mapE return . unE +-- | Output.+-- Execute the 'IO' action whenever the event occurs.+--+-- This version of 'reactimate' can deal with values obtained+-- from the 'changes' function.+reactimate' :: Event (Future (IO ())) -> MomentIO ()+reactimate' = MIO . Prim.addReactimate . Prim.mapE unF . unE++ -- | Input, -- obtain an 'Event' from an 'AddHandler'. -- -- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called.-fromAddHandler :: Frameworks t => AddHandler a -> Moment t (Event t a)-fromAddHandler = M . fmap singletonsE . Prim.fromAddHandler+fromAddHandler ::AddHandler a -> MomentIO (Event a)+fromAddHandler = MIO . fmap E . Prim.fromAddHandler  -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time.@@ -166,93 +178,131 @@ -- -- This function is occasionally useful, but -- the recommended way to obtain 'Behaviors' is by using 'fromChanges'.--- +-- -- Ideally, the argument IO action just polls a mutable variable, -- it should not perform expensive computations. -- Neither should its side effects affect the event network significantly.-fromPoll :: Frameworks t => IO a -> Moment t (Behavior t a)-fromPoll = M . fmap B . Prim.fromPoll+fromPoll :: IO a -> MomentIO (Behavior a)+fromPoll = MIO . fmap B . Prim.fromPoll  -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes.--- +-- -- This is essentially just an application of the 'stepper' combinator.-fromChanges :: Frameworks t => a -> AddHandler a -> Moment t (Behavior t a)-fromChanges initial changes = stepper initial <$> fromAddHandler changes+fromChanges :: a -> AddHandler a -> MomentIO (Behavior a)+fromChanges initial changes = do+    e <- fromAddHandler changes+    stepper initial e  -- | Output,--- observe when a 'Behavior' changes.--- --- Strictly speaking, a 'Behavior' denotes a value that--- varies /continuously/ in time,--- so there is no well-defined event which indicates when the behavior changes.--- --- Still, for reasons of efficiency, the library provides a way to observe--- changes when the behavior is a step function, for instance as --- created by 'stepper'. There are no formal guarantees,--- but the idea is that+-- return an 'Event' that is adapted to the changes of a 'Behavior'. ----- > changes (stepper x e) = return (calm e)+-- Remember that semantically, a 'Behavior' is a function @Behavior a = Time -> a@.+-- This means that a Behavior does not have a notion of \"changes\" associated with it.+-- For instance, the following Behaviors are equal: ----- WARNING: The values of the event will not become available--- until event processing is complete. Use them within 'reactimate'.--- If you try to access them before that, the program--- will be thrown into an infinite loop.-changes :: Frameworks t => Behavior t a -> Moment t (Event t a)-changes = return . singletonsE . Prim.changesB . unB+-- > stepper 0 []+-- > = stepper 0 [(time1, 0), (time2, 0)]+-- > = stepper 0 $ zip [time1,time2..] (repeat 0)+--+-- In principle, to perform IO actions with the value of a Behavior,+-- one has to sample it using an 'Event' and the 'apply' function.+--+-- However, in practice, Behaviors are usually step functions.+-- For reasons of efficiency, the library provides a way+-- to obtain an Event that /mostly/ coincides with the steps of a Behavior,+-- so that sampling is only done at a few select points in time.+-- The idea is that+--+-- > changes =<< stepper x e  =  return e+--+-- Please use 'changes' only in a ways that do /not/ distinguish+-- between the different expressions for the same Behavior above.+--+-- Note that the value of the event is actually the /new/ value,+-- i.e. that value slightly after this point in time. (See the documentation of 'stepper').+-- This is more convenient.+-- However, the value will not become available until after event processing is complete;+-- this is indicated by the type 'Future'.+-- It can be used only in the context of 'reactimate''.+changes :: Behavior a -> MomentIO (Event (Future a))+changes = return . E . Prim.mapE F . Prim.changesB . unB --- | Output,--- observe the initial value contained in a 'Behavior'.-initial :: Behavior t a -> Moment t a-initial = M . Prim.initialB . unB+{- $changes +Note: If you need a variant of the 'changes' function that does /not/+have the additional 'Future' type, then the following code snippet+may be useful: --- | Dummy type needed to simulate impredicative polymorphism.-newtype FrameworksMoment a-    = FrameworksMoment-    { runFrameworksMoment :: forall t. Frameworks t => Moment t a }+> plainChanges :: Behavior a -> MomentIO (Event a)+> plainChanges b = do+>     (e, handle) <- newEvent+>     eb <- changes b+>     reactimate' $ (fmap handle) <$> eb+>     return e -unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a-unFM = runFrameworksMoment+However, this approach is not recommended, because the result 'Event'+will occur /slightly/ later than the event returned by 'changes'.+In fact, there is no guarantee whatsoever about what /slightly/ means+in this context. Still, it is useful in some cases. --- | Dynamically add input and output to an existing event network.+-}++-- | Impose a different sampling event on a 'Behavior'. ----- Note: You can even do 'IO' actions here, but there is no--- guarantee about the order in which they are executed.-execute-    :: Frameworks t-    => Event t (FrameworksMoment a)-    -> Moment t (Event t a)-execute = M-    . fmap singletonsE . Prim.executeE-    . Prim.mapE (fmap last . sequence . map (unM . unFM) )-    . unE+-- The 'Behavior' will have the same values as before, but the event returned+-- by the 'changes' function will now happen simultaneously with the+-- imposed event.+--+-- Note: This function is useful only in very specific circumstances.+imposeChanges :: Behavior a -> Event () -> Behavior a+imposeChanges b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e)) +{- | Dynamically add input and output to an existing event network.+++Note: You can perform 'IO' actions here, which is useful if you want+to register additional event handlers dynamically.++However, if two arguments to 'execute' occur simultaneously,+then the order in which the 'IO' therein are executed is unspecified.+For instance, in the following code++> example e = do+>       e1 <- execute (liftIO (putStrLn "A") <$ e)+>       e2 <- execute (liftIO (putStrLn "B") <$ e)+>       return (e1,e2)++it is unspecified whether @A@ or @B@ are printed first.++Moreover, if the result 'Event' of this function has been garbage collected,+it may also happen that the actions are not executed at all.+In the example above, if the events `e1` and `e2` are not used any further,+then it can be that neither @A@ nor @B@ will be printed.++If your main goal is to reliably turn events into 'IO' actions,+use the 'reactimate' and 'reactimate'' functions instead.+-}+execute :: Event (MomentIO a) -> MomentIO (Event a)+execute = MIO . fmap E . Prim.executeE . Prim.mapE unMIO . unE+ -- $liftIO--- +-- -- > liftIO :: Frameworks t => IO a -> Moment t a -- -- Lift an 'IO' action into the 'Moment' monad. -{-# DEPRECATED liftIONow  "Use  liftIO  instead." #-}--- | Deprecated. Use 'liftIO' instead.-liftIONow :: Frameworks t => IO a -> Moment t a-liftIONow = liftIO- -- | Lift an 'IO' action into the 'Moment' monad, -- but defer its execution until compilation time. -- This can be useful for recursive definitions using 'MonadFix'.-liftIOLater :: Frameworks t => IO () -> Moment t ()-liftIOLater = M . Prim.liftIOLater+liftIOLater :: IO () -> MomentIO ()+liftIOLater = MIO . Prim.liftIOLater  -- | Compile the description of an event network -- into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on.------ Event networks are described in the 'Moment' monad--- and use the 'Frameworks' class constraint.-compile :: (forall t. Frameworks t => Moment t ()) -> IO EventNetwork-compile m = fmap EN $ Prim.compile $ unM (m :: Moment (FrameworksD, t) ())+compile :: MomentIO () -> IO EventNetwork+compile = fmap EN . Prim.compile . unMIO  {-----------------------------------------------------------------------------     Running event networks@@ -268,8 +318,8 @@ actuate = Prim.actuate . unEN  -- | Pause an event network.--- Immediately stop producing output and--- unregister all event handlers for inputs.+-- Immediately stop producing output.+-- (In a future version, it will also unregister all event handlers for inputs.) -- Hence, the network stops responding to input events, -- but it's state will be preserved. --@@ -282,61 +332,92 @@ pause :: EventNetwork -> IO () pause   = Prim.pause . unEN +-- | PROVISIONAL.+-- Measure of the number of events in the event network.+-- Useful for understanding space usage.+getSize :: EventNetwork -> IO Int+getSize = Prim.getSize . unEN+ {-----------------------------------------------------------------------------+    Utilities+------------------------------------------------------------------------------}+-- | Build an 'Event' together with an 'IO' action that can+-- fire occurrences of this event. Variant of 'newAddHandler'.+--+-- This function is mainly useful for passing callback functions+-- inside a 'reactimate'.+newEvent :: MomentIO (Event a, Handler a)+newEvent = do+    (addHandler, fire) <- liftIO newAddHandler+    e <- fromAddHandler addHandler+    return (e,fire)++-- | Build a 'Behavior' together with an 'IO' action that can+-- update this behavior with new values.+--+-- Implementation:+--+-- > newBehavior a = do+-- >     (e, fire) <- newEvent+-- >     b         <- stepper a e+-- >     return (b, fire)+newBehavior :: a -> MomentIO (Behavior a, Handler a)+newBehavior a = do+    (e, fire) <- newEvent+    b         <- stepper a e+    return (b, fire)++-- | Build a new 'Event' that contains the result+-- of an IO computation.+-- The input and result events will /not/ be simultaneous anymore,+-- the latter will occur /later/ than the former.+--+-- Please use the 'fmap' for 'Event' if your computation is pure.+--+-- Implementation:+--+-- > mapEventIO f e1 = do+-- >     (e2, handler) <- newEvent+-- >     reactimate $ (\a -> f a >>= handler) <$> e1+-- >     return e2+mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b)+mapEventIO f e1 = do+    (e2, handler) <- newEvent+    reactimate $ (f >=> handler) <$> e1+    return e2++{-----------------------------------------------------------------------------     Simple use ------------------------------------------------------------------------------}--- | Interpret by using a framework internally.--- Only useful for testing library internals.-interpretFrameworks :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]]+-- | Interpret an event processing function by building an 'EventNetwork'+-- and running it. Useful for testing, but uses 'MomentIO'.+-- See 'interpret' for a plain variant.+interpretFrameworks :: (Event a -> MomentIO (Event b)) -> [Maybe a] -> IO [Maybe b] interpretFrameworks f xs = do-    output                    <- newIORef []+    output                    <- newIORef Nothing     (addHandler, runHandlers) <- newAddHandler     network                   <- compile $ do-        e <- fromAddHandler addHandler-        reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e)+        e1 <- fromAddHandler addHandler+        e2 <- f e1+        reactimate $ writeIORef output . Just <$> e2      actuate network-    bs <- forM xs $ \x -> do-        runHandlers x-        bs <- readIORef output-        writeIORef output []-        return bs-    return bs+    forM xs $ \x -> do+        case x of+            Nothing -> return Nothing+            Just x  -> do+                runHandlers x+                b <- readIORef output+                writeIORef output Nothing+                return b  -- | Simple way to write a single event handler with -- functional reactive programming.-interpretAsHandler-    :: (forall t. Event t a -> Event t b)-    -> AddHandler a -> AddHandler b-interpretAsHandler f addHandlerA = \handlerB -> do+interpretAsHandler :: (Event a -> Moment (Event b)) -> AddHandler a -> AddHandler b+interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do     network <- compile $ do-        e <- fromAddHandler addHandlerA-        reactimate $ handlerB <$> f e+        e1 <- fromAddHandler addHandlerA+        e2 <- liftMoment (f e1)+        reactimate $ handlerB <$> e2     actuate network     return (pause network)---{------------------------------------------------------------------------------    Utilities-------------------------------------------------------------------------------}-{-$utilities--    This section collects a few convenience functions-    for unusual use cases. For instance:-    -    * The event-based framework you want to hook into is poorly designed-    -    * You have to write your own event loop and roll a little event framework---}---- | Build an 'Event' together with an 'IO' action that can --- fire occurrences of this event. Variant of 'newAddHandler'.--- --- This function is mainly useful for passing callback functions--- inside a 'reactimate'.-newEvent :: Frameworks t => Moment t (Event t a, a -> IO ())-newEvent = do-    (addHandler, fire) <- liftIO $ newAddHandler-    e <- fromAddHandler addHandler-    return (e,fire)
− src/Reactive/Banana/Frameworks/AddHandler.hs 
@@ -1,55 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Frameworks.AddHandler (-    -- * Synopsis-    -- | Various utility functions concerning event handlers.-    -    -- * Documentation-    AddHandler, newAddHandler,-    mapIO, filterAddHandler,-    ) where---import Data.IORef-import qualified Data.Unique -- ordinary uniques here, because they are Ord--import qualified Data.Map as Map--type Map = Map.Map--{------------------------------------------------------------------------------    AddHandler-------------------------------------------------------------------------------}--- | A value of type @AddHandler a@ is just a facility for registering--- callback functions, also known as event handlers.--- --- The type is a bit mysterious, it works like this:--- --- > do unregisterMyHandler <- addHandler myHandler------ The argument is an event handler that will be registered.--- The return value is an action that unregisters this very event handler again.-type AddHandler a = (a -> IO ()) -> IO (IO ())---- | Apply a function with side effects to an 'AddHandler'-mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b-mapIO f addHandler = \h -> addHandler $ \x -> f x >>= h ---- | Filter event occurrences that don't return 'True'.-filterAddHandler :: (a -> IO Bool) -> AddHandler a -> AddHandler a-filterAddHandler f addHandler = \h ->-    addHandler $ \x -> f x >>= \b -> if b then h x else return ()---- | Build a facility to register and unregister event handlers.-newAddHandler :: IO (AddHandler a, a -> IO ())-newAddHandler = do-    handlers <- newIORef Map.empty-    let addHandler k = do-            key <- Data.Unique.newUnique-            modifyIORef handlers $ Map.insert key k-            return $ modifyIORef handlers $ Map.delete key-        runHandlers x =-            mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers-    return (addHandler, runHandlers)-
− src/Reactive/Banana/Internal/Cached.hs 
@@ -1,72 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Internal.Cached (-    -- | Utility for executing monadic actions once-    -- and then retrieving values from a cache.-    -- -    -- Very useful for observable sharing.-    HasVault(..),-    Cached, runCached, mkCached, fromPure,-    liftCached1, liftCached2,-    ) where--import Control.Monad-import Control.Monad.Fix-import Data.Unique.Really-import qualified Data.Vault.Lazy as Vault-import System.IO.Unsafe--{------------------------------------------------------------------------------    Cache type-------------------------------------------------------------------------------}-data Cached m a = Cached (m a)--runCached :: Cached m a -> m a-runCached (Cached x) = x---- | Type class for monads that have a 'Vault' that can be used.-class (Monad m, MonadFix m) => HasVault m where-    retrieve :: Vault.Key a -> m (Maybe a)-    write    :: Vault.Key a -> a -> m ()---- | An action whose result will be cached.--- Executing the action the first time in the monad will--- execute the side effects. From then on,--- only the generated value will be returned.-{-# NOINLINE mkCached #-}-mkCached :: HasVault m => m a -> Cached m a-mkCached m = unsafePerformIO $ do-    key <- Vault.newKey-    return $ Cached $ do-        ma <- retrieve key      -- look up calculation result-        case ma of-            Nothing -> mdo-                write key a     -- black-hole result first-                a <- m          -- evaluate-                return a-            Just a  -> return a -- return cached result---- | Return a pure value.--- Doesn't make use of the cache 'Vault'.-fromPure :: HasVault m => a -> Cached m a-fromPure = Cached . return--liftCached1-    :: HasVault m-    => (a -> m b)-    -> Cached m a -> Cached m b-liftCached1 f ca = mkCached $ do-    a <- runCached ca-    f a--liftCached2-    :: HasVault m-    => (a -> b -> m c)-    -> Cached m a -> Cached m b -> Cached m c-liftCached2 f ca cb = mkCached $ do-    a <- runCached ca-    b <- runCached cb-    f a b-
− src/Reactive/Banana/Internal/DependencyGraph.hs 
@@ -1,80 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.DependencyGraph (-    -- | Utilities for operating with dependency graphs.-    Deps,-    empty, dependOn, topologicalSort, -    ) where--import Data.Hashable-import qualified Data.HashMap.Lazy as Map-import qualified Data.HashSet as Set--type Map = Map.HashMap-type Set = Set.HashSet--{------------------------------------------------------------------------------    Dependency graph data type-------------------------------------------------------------------------------}--- dependency graph-data Deps a = Deps-    { dChildren :: Map a [a] -- children depend on their parents-    , dParents  :: Map a [a]-    , dRoots    :: Set a-    } deriving (Show)---- convenient queries-children deps x = maybe [] id . Map.lookup x $ dChildren deps-parents  deps x = maybe [] id . Map.lookup x $ dParents  deps---- the empty dependency graph-empty :: Hashable a => Deps a-empty = Deps-    { dChildren = Map.empty-    , dParents  = Map.empty-    , dRoots    = Set.empty-    }--{------------------------------------------------------------------------------    Operations-------------------------------------------------------------------------------}--- add a dependency to the graph-dependOn :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-dependOn x y deps0 = deps1-    where-    deps1 = deps0-        { dChildren = Map.insertWith (++) y [x] $ dChildren deps0-        , dParents  = Map.insertWith (++) x [y] $ dParents  deps0-        , dRoots    = roots-        }-    -    roots = when (null $ parents deps0 x) (Set.delete x)-          . when (null $ parents deps1 y) (Set.insert y)-          $ dRoots deps0-    -    when b f = if b then f else id---- order the nodes in a way such that no children comes before its parent-topologicalSort :: (Eq a, Hashable a) => Deps a -> [a]-topologicalSort deps = go (Set.toList $ dRoots deps) Set.empty-    where-    go []     _     = []-    go (x:xs) seen1 = x : go (adultChildren ++ xs) seen2-        where-        seen2         = Set.insert x seen1-        adultChildren = filter isAdult (children deps x)-        isAdult y     = all (`Set.member` seen2) (parents deps y)--{------------------------------------------------------------------------------    Small tests-------------------------------------------------------------------------------}-test = id-    . dependOn 'D' 'C'-    . dependOn 'D' 'B'-    . dependOn 'C' 'B'-    . dependOn 'B' 'A'-    . dependOn 'B' 'a'-    $ empty--
− src/Reactive/Banana/Internal/EventBehavior1.hs 
@@ -1,172 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Internal.EventBehavior1 (-    -- * Interpreter-    interpret, compile,-    -    -- * Basic combinators-    Event, Behavior,-    never, filterJust, unionWith, mapE, accumE, applyE,-    changesB, stepperB, pureB, applyB, mapB,-    -    -- * Dynamic event switching-    Moment,-    initialB, trimE, trimB, executeE, observeE, switchE, switchB,-    -    -- * Setup and IO-    addReactimate, fromAddHandler, fromPoll, liftIONow, liftIOLater,-    EventNetwork, pause, actuate,-    ) where--import Data.Functor-import Data.Functor.Identity-import Control.Monad (join, (<=<))-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class (lift)--import qualified Reactive.Banana.Internal.PulseLatch0 as Prim-import Reactive.Banana.Internal.Cached-import Reactive.Banana.Internal.InputOutput-import Reactive.Banana.Frameworks.AddHandler--type Network = Prim.Network-type Latch   = Prim.Latch-type Pulse   = Prim.Pulse--{------------------------------------------------------------------------------    Types-------------------------------------------------------------------------------}-type Behavior a = Cached Network (Latch a, Pulse ())-type Event a    = Cached Network (Pulse a)-type Moment     = Prim.NetworkSetup--runCachedM :: Cached Network a -> Moment a-runCachedM = Prim.liftNetwork . runCached--{------------------------------------------------------------------------------    Interpretation-------------------------------------------------------------------------------}-inputE :: InputChannel a -> Event a-inputE = mkCached . Prim.inputP--interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret (\pulse -> runCachedM =<< f (fromPure pulse))--compile :: Moment () -> IO EventNetwork-compile = Prim.compile--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-never       = mkCached $ Prim.neverP-unionWith f = liftCached2 $ Prim.unionWith f-filterJust  = liftCached1 $ Prim.filterJustP-accumE x    = liftCached1 $ Prim.accumP x-mapE f      = liftCached1 $ Prim.mapP f-applyE      = liftCached2 $ \(lf,_) px -> Prim.applyP lf px--changesB    = liftCached1 $ \(lx,px) -> Prim.tagFuture lx px---- Note: To enable more recursion,--- first create the latch and then create the event that is accumulated-stepperB a  = \c1 -> mkCached $ mdo-    l  <- Prim.stepperL a p1-    p1 <- runCached c1-    p2 <- Prim.mapP (const ()) p1-    return (l,p2)--pureB a = stepperB a never-applyB = liftCached2 $ \(l1,p1) (l2,p2) -> do-    p3 <- Prim.unionWith const p1 p2-    l3 <- Prim.applyL l1 l2-    return (l3,p3)-mapB f = applyB (pureB f)--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-initialB :: Behavior a -> Moment a-initialB b = Prim.liftNetwork $ do-    ~(l,_) <- runCached b-    Prim.valueL l--trimE :: Event a -> Moment (Moment (Event a))-trimE e = do-    p <- runCachedM e                  -- add pulse to network-    -- NOTE: if the pulse is not connected to an input node,-    -- it will be garbage collected right away.-    -- TODO: Do we need to check for this?-    return $ return $ fromPure p       -- remember it henceforth--trimB :: Behavior a -> Moment (Moment (Behavior a))-trimB b = do-    ~(l,p) <- runCachedM b             -- add behavior to network-    return $ return $ fromPure (l,p)   -- remember it henceforth---observeE :: Event (Moment a) -> Event a -observeE = liftCached1 $ Prim.executeP--executeE :: Event (Moment a) -> Moment (Event a)-executeE e = Prim.liftNetwork $ do-    p <- runCached e-    result <- Prim.executeP p-    return $ fromPure result--switchE :: Event (Moment (Event a)) -> Event a-switchE = liftCached1 $ \p1 -> do-    p2 <- Prim.mapP (runCachedM =<<) p1-    p3 <- Prim.executeP p2-    Prim.switchP p3--switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a-switchB = liftCached2 $ \(l0,p0) p1 -> do-    p2 <- Prim.mapP (runCachedM =<<) p1-    p3 <- Prim.executeP p2-    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 = Prim.unionWith (\_ _ -> ())--{------------------------------------------------------------------------------    Combinators - Setup and IO-------------------------------------------------------------------------------}-addReactimate :: Event (IO ()) -> Moment ()-addReactimate e = do-    p <- runCachedM e-    lift $ Prim.addReactimate p--liftIONow :: IO a -> Moment a-liftIONow = liftIO--liftIOLater :: IO () -> Moment ()-liftIOLater = lift . Prim.liftIOLater--fromAddHandler :: AddHandler a -> Moment (Event a)-fromAddHandler addHandler = do-    i <- liftIO newInputChannel-    p <- Prim.liftNetwork $ Prim.inputP i-    lift $ Prim.registerHandler $ mapIO (return . (:[]) . toValue i) addHandler-    return $ fromPure p--fromPoll :: IO a -> Moment (Behavior a)-fromPoll poll = do-    a <- liftIO poll-    e <- Prim.liftNetwork $ do-        pm <- Prim.mapP (const $ liftIO poll) Prim.alwaysP-        p  <- Prim.executeP pm-        return $ fromPure p-    return $ stepperB a e--type EventNetwork = Prim.EventNetwork-pause   = Prim.pause-actuate = Prim.actuate
− src/Reactive/Banana/Internal/InputOutput.hs 
@@ -1,71 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.InputOutput (-    -- * Synopsis-    -- | Manage the input and output of event graphs.-    -    -- * Input-    -- | Utilities for managing heterogenous input values.-    Channel, InputChannel, InputValue,-    -    newInputChannel, getChannel,-    fromValue, toValue,-    -    -- * Output-    -- | Stepwise execution of an event graph.-    Automaton(..), fromStateful, unfoldAutomaton,--    ) where--import Control.Applicative-import Control.Exception (evaluate)--import Data.Unique.Really-import qualified Data.Vault.Lazy  as Vault--{------------------------------------------------------------------------------    Storing heterogenous input values-------------------------------------------------------------------------------}-type Channel  = Unique          -- identifies an input-type Key      = Vault.Key       -- key to retrieve a value-type Value    = Vault.Vault     -- value storage--data InputChannel a  = InputChannel { getChannelC :: Channel, getKey :: Key a }-data InputValue      = InputValue   { getChannelV :: Channel, getValue :: Value }--newInputChannel :: IO (InputChannel a)-newInputChannel = InputChannel <$> newUnique <*> Vault.newKey--fromValue :: InputChannel a -> InputValue -> Maybe a-fromValue i v = Vault.lookup (getKey i) (getValue v)--toValue :: InputChannel a -> a -> InputValue-toValue i a = InputValue (getChannelC i) $ Vault.insert (getKey i) a Vault.empty---- convenience class for overloading-class HasChannel a where-    getChannel :: a -> Channel-instance HasChannel (InputChannel a) where getChannel = getChannelC-instance HasChannel (InputValue) where getChannel = getChannelV---{------------------------------------------------------------------------------    Stepwise execution-------------------------------------------------------------------------------}--- Automaton that takes input values and produces a result-data Automaton a = Step { runStep :: [InputValue] -> IO (Maybe a, Automaton a) }--fromStateful :: ([InputValue] -> s -> IO (Maybe a,s)) -> s -> Automaton a-fromStateful f s = Step $ \i -> do-    (a,s') <- f i s-    return (a, fromStateful f s')---- | Apply an automaton to a list of input values-unfoldAutomaton :: Automaton b -> InputChannel a -> [Maybe a] -> IO [Maybe b]-unfoldAutomaton _    _ []       = return []-unfoldAutomaton auto i (mx:mxs) = do-    (b, auto) <- runStep auto $ maybe [] (\x -> [toValue i x]) mx-    bs        <- unfoldAutomaton auto i mxs-    return (b:bs)-
− src/Reactive/Banana/Internal/Phantom.hs 
@@ -1,21 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}-module Reactive.Banana.Internal.Phantom (-    -- * Synopsis-    -- | Classes used to constrain the phantom type @t@ in the 'Moment' type.-    -    -- * Documentation-    Frameworks, FrameworksD,-    ) where---- | Class constraint on the type parameter @t@ of the 'Moment' monad.--- --- Indicates that we can add input and output to an event network.-class Frameworks t---- | Data type for discharging the 'Frameworks' constraint.-data FrameworksD--instance Frameworks (FrameworksD,t)
− src/Reactive/Banana/Internal/PulseLatch0.hs 
@@ -1,566 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, RecursiveDo, ExistentialQuantification,-    TypeSynonymInstances, FlexibleInstances #-}-module Reactive.Banana.Internal.PulseLatch0 where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Trans.RWS-import Control.Monad.IO.Class--import Data.IORef-import Data.Monoid (Endo(..))--import Control.Concurrent.MVar--import Reactive.Banana.Internal.Cached-import Reactive.Banana.Internal.InputOutput-import qualified Reactive.Banana.Internal.DependencyGraph as Deps-import Reactive.Banana.Frameworks.AddHandler--import Data.Hashable-import Data.Unique.Really-import qualified Data.Vault.Lazy as Vault--import Data.Functor.Identity-import System.IO.Unsafe--import Debug.Trace--type Deps = Deps.Deps--debug   s m = m-debugIO s m = liftIO (putStrLn s) >> m--{------------------------------------------------------------------------------    Graph data type-------------------------------------------------------------------------------}-data Graph = Graph-    { grPulse   :: Values                    -- pulse values-    , grLatch   :: Values                    -- latch values-    -    , grCache   :: Values                    -- cache for initialization--    , grDeps    :: Deps SomeNode             -- dependency information-    , grInputs  :: [Input]                   -- input  nodes-    }--type Values = Vault.Vault-type Key    = Vault.Key-type Input  =-    ( SomeNode-    , InputValue -> Values -> Values         -- write input value into graph-    )--emptyGraph :: Graph-emptyGraph = Graph-    { grPulse  = Vault.empty-    , grLatch  = Vault.empty-    , grCache  = Vault.empty-    , grDeps   = Deps.empty-    , grInputs = [(P alwaysP, const id)]-    }--{------------------------------------------------------------------------------    Graph evaluation-------------------------------------------------------------------------------}--- evaluate all the nodes in the graph once-evaluateGraph :: [InputValue] -> Graph -> Setup Graph-evaluateGraph inputs = fmap snd-    . uncurry (runNetworkAtomicT . performEvaluation)-    . buildEvaluationOrder-    . writeInputValues inputs--runReactimates (graph,reactimates) =-        sequence_ [action | pulse <- reactimates-                          , Just action <- [readPulseValue pulse graph]]-readPulseValue p = getValueP p . grPulse--writeInputValues inputs graph = graph { grPulse =-    concatenate [f x | (_,f) <- grInputs graph, x <- inputs] Vault.empty }--concatenate :: [a -> a] -> (a -> a)-concatenate = foldr (.) id--performEvaluation :: [SomeNode] -> NetworkSetup ()-performEvaluation = mapM_ evaluate-    where-    evaluate (P p) = evaluateP p-    evaluate (L l) = liftNetwork $ evaluateL l---- Figure out which nodes need to be evaluated.------ All nodes that are connected to current input nodes must be evaluated.--- The other nodes don't have to be evaluated, because they yield--- Nothing / don't change anyway.-buildEvaluationOrder :: Graph -> ([SomeNode], Graph)-buildEvaluationOrder graph = (Deps.topologicalSort $ grDeps graph, graph)---{------------------------------------------------------------------------------    Network monad-------------------------------------------------------------------------------}--- The 'Network' monad is used for evaluation and changes--- the state of the graph.-type NetworkT     = RWST Graph (Endo Graph) Graph-type Network      = NetworkT Identity-type NetworkSetup = NetworkT Setup---- lift pure Network computation into any monad--- very useful for its laziness-liftNetwork :: Monad m => Network a -> NetworkT m a-liftNetwork m = RWST $ \r s -> return . runIdentity $ runRWST m r s---- access initialization cache-instance (MonadFix m, Functor m) => HasVault (NetworkT m) where-    retrieve key = Vault.lookup key . grCache <$> get-    write key a  = modify $ \g -> g { grCache = Vault.insert key a (grCache g) }---- change a graph "atomically"-runNetworkAtomicT :: MonadFix m => NetworkT m a -> Graph -> m (a, Graph)-runNetworkAtomicT m g1 = mdo-    (x, g2, w2) <- runRWST m g3 g1  -- apply early graph gransformations-    let g3 = appEndo w2 g2          -- apply late  graph transformations-    return (x, g3)---- write pulse value immediately-writePulse :: Key (Maybe a) -> Maybe a -> Network ()-writePulse key x =-    modify $ \g -> g { grPulse = Vault.insert key x $ grPulse g }---- read pulse value immediately-readPulse :: Key (Maybe a) -> Network (Maybe a)-readPulse key = (getPulse key . grPulse) <$> get--getPulse key = join . Vault.lookup key---- write latch value immediately-writeLatch :: Key a -> a -> Network ()-writeLatch key x =-    modify $ \g -> g { grLatch = Vault.insert key x $ grLatch g }---- read latch value immediately-readLatch :: Key a -> Network a-readLatch key = (maybe err id . Vault.lookup key . grLatch) <$> get-    where err = error "readLatch: latch not initialized!"---- write latch value for future-writeLatchFuture :: Key a -> a -> Network ()-writeLatchFuture key x =-    tell $ Endo $ \g -> g { grLatch = Vault.insert key x $ grLatch g }---- read future latch value--- Note [LatchFuture]:---   warning: forcing the value early will likely result in an infinite loop-readLatchFuture :: Key a -> Network a-readLatchFuture key = (maybe err id . Vault.lookup key . grLatch) <$> ask-    where err = error "readLatchFuture: latch not found!"---- add a dependency-dependOn :: SomeNode -> SomeNode -> Network ()-dependOn x y = modify $ \g -> g { grDeps = Deps.dependOn x y $ grDeps g }--dependOns :: SomeNode -> [SomeNode] -> Network ()-dependOns x = mapM_ $ dependOn x---- link a Pulse key to an input channel-addInput :: Key (Maybe a) -> Pulse a -> InputChannel a -> Network ()-addInput key pulse channel =-    modify $ \g -> g { grInputs = (P pulse, input) : grInputs g }-    where-    input value-        | getChannel value == getChannel channel =-            Vault.insert key (fromValue channel value)-        | otherwise = id--{------------------------------------------------------------------------------    Setup monad-------------------------------------------------------------------------------}-{--    The 'Setup' monad allows us to do administrative tasks-    during graph evaluation.-    For instance, we can-        * add new reactimates-        * perform IO--}--type Reactimate = Pulse (IO ())-type SetupConf  =-    ( [Reactimate]                -- reactimate-    , [AddHandler [InputValue]]   -- fromAddHandler-    , [IO ()]                     -- liftIOLater-    )-type Setup  = RWST () SetupConf () IO--addReactimate :: Reactimate -> Setup ()-addReactimate x = tell ([x],[],[])--liftIOLater :: IO () -> Setup ()-liftIOLater x = tell ([],[],[x])--discardSetup :: Setup a -> IO a-discardSetup m = do-    (a,_,_) <- runRWST m () ()-    return a--registerHandler :: AddHandler [InputValue] -> Setup ()-registerHandler x = tell ([],[x],[])--runSetup :: Callback -> Setup a -> IO (a, [Reactimate])-runSetup callback m = do-    (a,_,(reactimates,addHandlers,liftIOLaters)) <- runRWST m () ()-    mapM_ ($ callback) addHandlers  -- register new event handlers-    sequence_ liftIOLaters          -- execute late IOs-    return (a,reactimates)--{------------------------------------------------------------------------------    Compilation.-    State machine IO stuff.-------------------------------------------------------------------------------}-type Callback = [InputValue] -> IO ()--data EventNetwork = EventNetwork-    { actuate :: IO ()-    , pause   :: IO ()-    }---- compile to an event network-compile :: NetworkSetup () -> IO EventNetwork-compile setup = do-    actuated <- newIORef False                   -- flag to set running status-    rstate   <- newEmptyMVar                     -- setup callback machinery-    let-        whenFlag flag action = readIORef flag >>= \b -> when b action-        callback inputs = whenFlag actuated $ do-            state0 <- takeMVar rstate            -- read and take lock-            -- pollValues <- sequence polls      -- poll mutable data-            (reactimates, state1)-                <- step inputs state0            -- calculate new state-            putMVar rstate state1                -- write state-            reactimates                          -- run IO actions afterwards--            -- register event handlers-            -- register :: IO (IO ())-            -- register = fmap sequence_ . sequence . map ($ run) $ inputs--        step inputs (g0,r0) = do                 -- evaluation function-            (g2,r1) <- runSetup callback $ evaluateGraph inputs g0-            let-                r2     = r0 ++ r1                -- concatenate reactimates-                runner = runReactimates (g2,r2)  -- don't run them yet!-            return (runner, (g2,r2))--    ((_,graph), reactimates)                     -- compile initial graph-        <- runSetup callback $ runNetworkAtomicT setup emptyGraph-    putMVar rstate (graph,reactimates)           -- set initial state-        -    return $ EventNetwork-        { actuate = writeIORef actuated True-        , pause   = writeIORef actuated False-        }---- make an interpreter-interpret :: (Pulse a -> NetworkSetup (Pulse b)) -> [Maybe a] -> IO [Maybe b]-interpret f xs = do-    i <- newInputChannel-    (result,graph) <- discardSetup $-        runNetworkAtomicT (f =<< liftNetwork (inputP i)) emptyGraph--    let-        step Nothing  g0 = return (Nothing,g0)-        step (Just a) g0 = do-            g1 <- discardSetup $ evaluateGraph [toValue i a] g0-            return (readPulseValue result g1, g1)-    -    mapAccumM step graph xs--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)--{------------------------------------------------------------------------------    Pulse and Latch types-------------------------------------------------------------------------------}-{--    evaluateL/P-        calculates the next value and makes sure that it's cached-    valueL/P-        retrieves the current value-    futureL-        future value of the latch-        see note [LatchFuture]-    uidL/P-        used for dependency tracking and evaluation order--}--data Pulse a = Pulse-    { evaluateP :: NetworkSetup ()-    , getValueP :: Values -> Maybe a-    , uidP      :: Unique-    }--data Latch a = Latch-    { evaluateL :: Network ()-    , valueL    :: Network a-    , futureL   :: Network a-    , uidL      :: Unique-    }---valueP :: Pulse a -> Network (Maybe a)-valueP p = getValueP p . grPulse <$> get--{--* Note [LatchCreation]--When creating a new latch from a pulse, we assume that the-pulse cannot fire at the moment that the latch is created.-This is important when switching latches, because of note [PulseCreation].--Likewise, when creating a latch, we assume that we do not-have to calculate the previous latch value.--* Note [PulseCreation]--We assume that we do not have to calculate a pulse occurrence-at the moment we create the pulse. Otherwise, we would have-to recalculate the dependencies *while* doing evaluation;-this is a recipe for desaster.---* Note [unsafePerformIO]--We're using @unsafePerformIO@ only to get @Key@ and @Unique@.-It's not great, but it works.--Unfortunately, using @IO@ as the base of the @Network@ monad-transformer doens't work because it doesn't support recursion-and @mfix@ very well.--We could use the @ST@ monad, but this would add a type parameter-to everything. A refactoring of this scope is too annoying for-my taste right now.---}---- make pulse from evaluation function-pulse' :: NetworkSetup (Maybe a) -> Network (Pulse a)-pulse' eval = unsafePerformIO $ do-    key <- Vault.newKey-    uid <- newUnique-    return $ return $ Pulse-        { evaluateP = liftNetwork . writePulse key =<< eval-        , getValueP = getPulse key-        , uidP      = uid-        }--pulse :: Network (Maybe a) -> Network (Pulse a)-pulse = pulse' . liftNetwork--neverP :: Network (Pulse a)-neverP = debug "neverP" $ unsafePerformIO $ do-    uid <- newUnique-    return $ return $ Pulse-        { evaluateP = return ()-        , getValueP = const Nothing-        , uidP      = uid-        }---- create a pulse that listens to input values-inputP :: InputChannel a -> Network (Pulse a)-inputP channel = debug "inputP" $ unsafePerformIO $ do-    key <- Vault.newKey-    uid <- newUnique-    return $ do-        let-            p = Pulse-                { evaluateP = return ()-                , getValueP = getPulse key-                , uidP      = uid-                }-        addInput key p channel-        return p---- event that always fires whenever the network processes events-alwaysP :: Pulse ()-alwaysP = debug "alwaysP" $ unsafePerformIO $ do-    uid <- newUnique-    return $ Pulse-        { evaluateP = return ()-        , getValueP = return $ Just ()-        , uidP      = uid-        }---- make latch from initial value, a future value and evaluation function-latch :: a -> a -> Network (Maybe a) -> Network (Latch a)-latch now future eval = unsafePerformIO $ do-    key <- Vault.newKey-    uid <- newUnique-    return $ do-        -- Initialize with current and future latch value.-        -- See note [LatchCreation].-        writeLatch key now-        writeLatchFuture key future-        -        return $ Latch-            { evaluateL = maybe (return ()) (writeLatchFuture key) =<< eval-            , valueL    = readLatch key-            , futureL   = readLatchFuture key-            , uidL      = uid-            }--pureL :: a -> Network (Latch a)-pureL a = debug "pureL" $ unsafePerformIO $ do-    uid <- liftIO newUnique-    return $ return $ Latch-        { evaluateL = return ()-        , valueL    = return a-        , futureL   = return a-        , uidL      = uid-        }--{------------------------------------------------------------------------------    Existential quantification over Pulse and Latch-    for dependency tracking-------------------------------------------------------------------------------}-data SomeNode = forall a. P (Pulse a) | forall a. L (Latch a)--instance Eq SomeNode where-    (L x) == (L y)  =  uidL x == uidL y-    (P x) == (P y)  =  uidP x == uidP y-    _     == _      =  False--instance Hashable SomeNode where-    hashWithSalt s (P p) = hashWithSalt s . hashUnique $ uidP p-    hashWithSalt s (L l) = hashWithSalt s . hashUnique $ uidL l--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-stepperL :: a -> Pulse a -> Network (Latch a)-stepperL a p = debug "stepperL" $ do-    -- @a@ is indeed the future latch value. See note [LatchCreation].-    x <- latch a a (valueP p)-    L x `dependOn` P p-    return x--accumP :: a -> Pulse (a -> a) -> Network (Pulse a)-accumP a p = debug "accumP" $ mdo-        x       <- stepperL a result-        result  <- pulse $ eval <$> valueL x <*> valueP p-        -- Evaluation order of the result pulse does *not*-        -- depend on the latch. It does depend on latch value,-        -- though, so don't garbage collect that one.-        P result `dependOn` P p-        return result-    where-    eval _ Nothing  = Nothing-    eval x (Just f) = let y = f x in y `seq` Just y  -- strict evaluation--applyP :: Latch (a -> b) -> Pulse a -> Network (Pulse b)-applyP f x = debug "applyP" $ do-    result <- pulse $ fmap <$> valueL f <*> valueP x-    P result `dependOn` P x-    return result---- tag a pulse with future values of a latch--- Caveat emptor.-tagFuture :: Latch a -> Pulse b -> Network (Pulse a)-tagFuture f x = debug "tagFuture" $ do-    result <- pulse $ fmap . const <$> futureL f <*> valueP x-    P result `dependOn` P x-    return result--mapP :: (a -> b) -> Pulse a -> Network (Pulse b)-mapP f p = debug "mapP" $ do-    result <- pulse $ fmap f <$> valueP p-    P result `dependOn` P p-    return result--filterJustP :: Pulse (Maybe a) -> Network (Pulse a)-filterJustP p = debug "filterJustP" $ do-    result <- pulse $ join <$> valueP p-    P result `dependOn` P p-    return result--unionWith :: (a -> a -> a) -> Pulse a -> Pulse a -> Network (Pulse a)-unionWith f px py = debug "unionWith" $ do-        result <- pulse $ eval <$> valueP px <*> valueP py-        P result `dependOns` [P px, P py]-        return result-    where-    eval (Just x) (Just y) = Just (f x y)-    eval (Just x) Nothing  = Just x-    eval Nothing  (Just y) = Just y-    eval Nothing  Nothing  = Nothing---applyL :: Latch (a -> b) -> Latch a -> Network (Latch b)-applyL lf lx = debug "applyL" $ do-        -- The value in the next cycle is always the future value.-    -- See note [LatchCreation]-    let eval = ($) <$> futureL lf <*> futureL lx-    future <- eval-    now    <- ($) <$> valueL lf <*> valueL lx-    result <- latch now future $ fmap Just eval-    L result `dependOns` [L lf, L lx]-    return result--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-executeP :: Pulse (NetworkSetup a) -> Network (Pulse a)-executeP pn = do-    result <- pulse' $ do-        mp <- liftNetwork $ valueP pn-        case mp of-            Just p  -> Just <$> p-            Nothing -> return Nothing-    P result `dependOn` P pn-    return result--switchP :: Pulse (Pulse a) -> Network (Pulse a)-switchP pp = mdo-    never <- neverP-    lp    <- stepperL never pp-    let-        eval = do-            newPulse <- valueP pp-            case newPulse of-                Nothing -> return ()-                Just p  -> P result `dependOn` P p  -- check in new pulse-            valueP =<< valueL lp                    -- fetch value from old pulse-            -- we have to use the *old* event value due to note [LatchCreation]-    result <- pulse eval-    P result `dependOns` [L lp, P pp]-    return result---switchL :: Latch a -> Pulse (Latch a) -> Network (Latch a)-switchL l p = mdo-    ll <- stepperL l p-    let-        -- switch to a new latch-        switchTo l = do-            L result `dependOn` L l-            futureL l-        -- calculate future value of the result latch-        eval = do-            mp <- valueP p-            case mp of-                Nothing -> futureL =<< valueL ll-                Just l  -> switchTo l--    now    <- valueL  l                 -- see note [LatchCreation]-    future <- futureL l-    result <- latch now future $ Just <$> eval-    L result `dependOns` [L l, P p]-    return result--
− src/Reactive/Banana/Internal/Types2.hs 
@@ -1,63 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.Types2 (-    -- | Primitive types.-    Event (..), Behavior (..), Moment (..)-    ) where--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Fix--import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Phantom--{-| @Event t a@ represents a stream of events as they occur in time.-Semantically, you can think of @Event t a@ as an infinite list of values-that are tagged with their corresponding time of occurence,--> type Event t a = [(Time,a)]--}-newtype Event t a = E { unE :: Prim.Event [a] }--{-| @Behavior t a@ represents a value that varies in time. Think of it as--> type Behavior t a = Time -> a--}-newtype Behavior t a = B { unB :: Prim.Behavior a }--{-| The 'Moment' monad denotes a value at a particular /moment in time/.--This monad is not very interesting, it is mainly used for book-keeping.-In particular, the type parameter @t@ is used-to disallow various unhealthy programs.--This monad is also used to describe event networks-in the "Reactive.Banana.Frameworks" module.-This only happens when the type parameter @t@-is constrained by the 'Frameworks' class.--To be precise, an expression of type @Moment t a@ denotes-a value of type @a@ that is observed at a moment in time-which is indicated by the type parameter @t@.---}-newtype Moment t a = M { unM :: Prim.Moment a }----- boilerplate class instances-instance Monad (Moment t) where-    return  = M . return-    m >>= g = M $ unM m >>= unM . g--instance Applicative (Moment t) where-    pure    = M . pure-    f <*> a = M $ unM f <*> unM a--instance MonadFix (Moment t) where   mfix f  = M $ mfix (unM . f)-instance Functor  (Moment t) where   fmap f  = M . fmap f . unM--instance Frameworks t => MonadIO (Moment t) where-    liftIO = M . Prim.liftIONow
src/Reactive/Banana/Model.hs view
@@ -1,151 +1,184 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Reactive.Banana.Model (     -- * Synopsis-    -- | Model implementation of the abstract syntax tree.-    -    -- * Description-    -- $model+    -- | Model implementation for learning and testing. -    -- * Combinators-    -- ** Data types-    Event, Behavior,-    -- ** Basic-    never, filterJust, unionWith, mapE, accumE, applyE,-    stepperB, pureB, applyB, mapB,-    -- ** Dynamic event switching-    Moment,-    initialB, trimE, trimB, observeE, switchE, switchB,-        -    -- * Interpretation+    -- * Overview+    -- $overview++    -- * Core Combinators+    -- ** Event and Behavior+    Nat, Time,+    Event(..), Behavior(..),     interpret,+    -- ** First-order+    module Control.Applicative,+    never, unionWith, mergeWith, filterJust, apply,+    -- ** Moment and accumulation+    Moment(..), accumE, stepper,+    -- ** Higher-order+    valueB, observeE, switchE, switchB,     ) where  import Control.Applicative-import Control.Monad (join)+import Control.Monad+import Control.Monad.Fix+import Data.These (These(..), these)+import Data.Maybe (fromMaybe) -{-$model+{-$overview -This module contains the model implementation for the primitive combinators-defined "Reactive.Banana.Internal.AST"-which in turn are the basis for the official combinators-documented in "Reactive.Banana.Combinators".+This module reimplements the key FRP types and functions from the module+"Reactive.Banana.Combinators" in a way that is hopefully easier to understand.+Thereby, this model also specifies the semantics of the library.+Of course, the real implementation is much more efficient than this model here. -Look at the source code to make maximal use of this module.+To understand the model in detail, look at the source code! (If there is no link to the source code at every type signature, then you have to run cabal with --hyperlink-source flag.) -This model is /authoritative/: when observed with the 'interpretModel' function,-both the actual implementation and its model /must/ agree on the result.-Note that this must also hold for recursive and partial definitions+This model is /authoritative/:+Event functions that have been constructed using the same combinators+/must/ give the same results when run with the @interpret@ function+from either the module "Reactive.Banana.Combinators"+or the module "Reactive.Banana.Model".+This must also hold for recursive and partial definitions (at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). -Concerning time and space complexity, the model is not authoritative, however.-Implementations are free to be much more efficient. -}  {------------------------------------------------------------------------------    Basic Combinators+    Event and Behavior ------------------------------------------------------------------------------}-type Event a    = [Maybe a]             -- should be abstract-data Behavior a = StepperB a (Event a)  -- should be abstract+-- | Natural numbers (poorly represented).+type Nat = Int -interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]-interpret f e = f e 0+-- | The FRP model used in this library is actually a model with continuous time.+--+-- However, it can be shown that this model is observationally+-- equivalent to a particular model with (seemingly) discrete time steps,+-- which is implemented here.+-- The main reason for doing this is to be able to handle recursion correctly.+-- Details will be explained elsewhere.+type Time = Nat -- begins at t = 0 -never :: Event a-never = repeat Nothing+-- | Event is modeled by an /infinite/ list of 'Maybe' values.+-- It is isomorphic to @Time -> Maybe a@.+--+-- 'Nothing' indicates that no occurrence happens,+-- while 'Just' indicates that an occurrence happens.+newtype Event a = E { unE :: [Maybe a] } deriving (Show) -filterJust :: Event (Maybe a) -> Event a-filterJust = map join+-- | Behavior is modeled by an /infinite/ list of values.+-- It is isomorphic to @Time -> a@.+newtype Behavior a = B { unB :: [a] } deriving (Show) -unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f = zipWith g-    where-    g (Just x) (Just y) = Just $ f x y-    g (Just x) Nothing  = Just x-    g Nothing  (Just y) = Just y-    g Nothing  Nothing  = Nothing+interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]+interpret f as =+    take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing) -mapE f  = applyE (pureB f)+{-----------------------------------------------------------------------------+    First-order+------------------------------------------------------------------------------}+instance Functor Event where+    fmap f (E xs) = E (fmap (fmap f) xs) -applyE :: Behavior (a -> b) -> Event a -> Event b-applyE _               []     = []-applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs-    where-    step a (Nothing:b) = stepperB a b-    step _ (Just a :b) = stepperB a b+instance Functor Behavior where+    fmap f (B xs) = B (fmap f xs) -accumE :: a -> Event (a -> a) -> Event a-accumE x []           = []-accumE x (Nothing:fs) = Nothing : accumE x fs-accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) +instance Applicative Behavior where+    pure x          = B $ repeat x+    (B f) <*> (B x) = B $ zipWith ($) f x -stepperB :: a -> Event a -> Behavior a-stepperB = StepperB+never :: Event a+never = E $ repeat Nothing --- applicative functor-pureB x = stepperB x never+unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a+unionWith = mergeWith id id -applyB :: Behavior (a -> b) -> Behavior a -> Behavior b-applyB (StepperB f fe) (StepperB x xe) =-    stepperB (f x) $ mapE (uncurry ($)) pair+mergeWith+  :: (a -> c)+  -> (b -> c)+  -> (a -> b -> c)+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h xs ys = these f g h <$> merge xs ys++merge :: Event a -> Event b -> Event (These a b)+merge (E xs) (E ys) = E $ zipWith combine xs ys     where-    pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe)-    changeL f (_,x) = (f,x)-    changeR x (f,_) = (f,x)+    combine Nothing  Nothing  = Nothing+    combine (Just x) Nothing  = Just (This x)+    combine Nothing  (Just y) = Just (That y)+    combine (Just x) (Just y) = Just (These x y) -mapB f = applyB (pureB f)+filterJust :: Event (Maybe a) -> Event a+filterJust = E . fmap join . unE +apply :: Behavior (a -> b) -> Event a -> Event b+apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE+ {------------------------------------------------------------------------------    Dynamic Event Switching+    Moment and accumulation ------------------------------------------------------------------------------}-type Time     = Int-type Moment a = Time -> a     -- should be abstract+newtype Moment a = M { unM :: Time -> a } -{-+instance Functor     Moment where fmap f = M . fmap f . unM+instance Applicative Moment where+    pure   = M . const+    (<*>)  = ap instance Monad Moment where-    return  = const-    m >>= g = \time -> g (m time) time--}+    return = pure+    (M m) >>= k = M $ \time -> unM (k $ m time) time -initialB :: Behavior a -> Moment a-initialB (StepperB x _) = return x+instance MonadFix Moment where+    mfix f = M $ mfix (unM . f) -trimE :: Event a -> Moment (Moment (Event a))-trimE e = \now -> \later -> drop (later - now) e+-- Forget all event occurences before a particular time+forgetE :: Time -> Event a -> [Maybe a]+forgetE time (E xs) = drop time xs -trimB :: Behavior a -> Moment (Moment (Behavior a))-trimB b = \now -> \later -> bTrimmed !! (later - now)+stepper :: a -> Event a -> Moment (Behavior a)+stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)     where-    bTrimmed = iterate drop1 b+    step i ~(x:xs) = i : step next xs+        where next = fromMaybe i x -    drop1 (StepperB x []          ) = StepperB x never-    drop1 (StepperB x (Just y :ys)) = StepperB y ys-    drop1 (StepperB x (Nothing:ys)) = StepperB x ys+-- Expressed using recursion and the other primitives+-- FIXME: Strictness!+accumE :: a -> Event (a -> a) -> Moment (Event a)+accumE a e1 = mdo+    let e2 = ((\a f -> f a) <$> b) `apply` e1+    b <- stepper a e2+    return e2 +{-----------------------------------------------------------------------------+    Higher-order+------------------------------------------------------------------------------}+valueB :: Behavior a -> Moment a+valueB (B b) = M $ \time -> b !! time+ observeE :: Event (Moment a) -> Event a-observeE = zipWith (\time -> fmap ($ time)) [0..]+observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE -switchE :: Event (Moment (Event a)) -> Event a-switchE = step never . observeE+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-    step ys     []           = ys-    step (y:ys) (Nothing:xs) = y : step ys xs -    step (y:ys) (Just zs:xs) = y : step (drop 1 zs) xs-    -- assume that the dynamic events are at least as long as the-    -- switching event+    switch (x:xs) (Nothing : ys) = x : switch xs ys+    switch (x: _) (Just xs : ys) = x : switch (tail xs) ys -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a-switchB (StepperB x e) = stepperB x . step e . observeE-    where-    step ys     []                        = ys-    step (y:ys) (Nothing             :xs) =          y : step ys xs -    step (y:ys) (Just (StepperB x zs):xs) = Just value : step (drop 1 zs) xs-        where-        value = case zs of-            Just z : _ -> z -- new behavior changes right away-            _          -> x -- new behavior stays constant for a while+forgetDiagonalE :: Event (Event a) -> Event [Maybe a]+forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE +switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB b e = diagonalB <$> stepper b e +diagonalB :: Behavior (Behavior a) -> Behavior a+diagonalB = B . zipWith (\time xs -> xs !! time) [0..] . map unB . unB
+ src/Reactive/Banana/Prim/High/Cached.hs view
@@ -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
+ src/Reactive/Banana/Prim/High/Combinators.hs view
@@ -0,0 +1,260 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE FlexibleInstances, NamedFieldPuns, NoMonomorphismRestriction #-}+module Reactive.Banana.Prim.High.Combinators where++import           Control.Exception+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+    , size :: IORef Int+    , s :: MVar Prim.Network+    }++runStep :: EventNetwork -> Prim.Step -> IO ()+runStep EventNetwork{ actuated, s, size } f = whenFlag actuated $ do+    output <- mask $ \restore -> do+        s1 <- takeMVar s                   -- read and take lock+        -- pollValues <- sequence polls    -- poll mutable data+        (output, s2) <-+            restore (f s1)                 -- calculate new state+                `onException` putMVar s s1 -- on error, restore the original state+        putMVar s s2                       -- write state+        writeIORef size =<< Prim.getSize s2+        return output+    output                                 -- run IO actions afterwards+  where+    whenFlag flag action = readIORef flag >>= \b -> when b action++getSize :: EventNetwork -> IO Int+getSize EventNetwork{size} = readIORef size++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+    size     <- newIORef 0++    let eventNetwork = EventNetwork{ actuated, s, size }++    (_output, s0) <-                             -- compile initial graph+        Prim.compile (runReaderT setup eventNetwork) =<< Prim.emptyNetwork+    putMVar s s0                                -- set initial state+    writeIORef size =<< Prim.getSize s0++    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 ())
+ src/Reactive/Banana/Prim/Low/Graph.hs view
@@ -0,0 +1,300 @@+{-# language BangPatterns #-}+{-# language NamedFieldPuns #-}+{-# language RecordWildCards #-}+{-# language ScopedTypeVariables #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Low.Graph+    ( Graph+    , empty+    , getOutgoing+    , getIncoming+    , size+    , edgeCount+    , listConnectedVertices++    , deleteVertex+    , insertEdge+    , deleteEdge+    , clearPredecessors+    , collectGarbage++    , topologicalSort+    , Step (..)+    , walkSuccessors+    , walkSuccessors_++    -- * Internal+    , Level+    , getLevel++    -- * Debugging+    , showDot+    ) where++import Data.Functor.Identity+    ( Identity (..) )+import Data.Hashable+    ( Hashable )+import Data.Maybe+    ( fromMaybe )+import Reactive.Banana.Prim.Low.GraphTraversal+    ( reversePostOrder )++import qualified Data.List as L+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import qualified Data.PQueue.Prio.Min as Q++type Queue = Q.MinPQueue+type Map = Map.HashMap+type Set = Set.HashSet++{-----------------------------------------------------------------------------+    Levels+------------------------------------------------------------------------------}+-- | 'Level's are used to keep track of the order of vertices —+-- Lower levels come first.+type Level = Int++ground :: Level+ground = 0++{-----------------------------------------------------------------------------+    Graph+------------------------------------------------------------------------------}+{- | A directed graph+whose set of vertices is the set of all values of the type @v@+and whose edges are associated with data of type @e@.++Note that a 'Graph' does not have a notion of vertex membership+— by design, /all/ values of the type @v@ are vertices of the 'Graph'.+The main purpose of 'Graph' is to keep track of directed edges between+vertices; a vertex with at least one edge incident on it is called+a /connected vertex/.+For efficiency, only the connected vertices are stored.+-}+data Graph v e = Graph+    { -- | Mapping from each vertex to its direct successors+      -- (possibly empty).+      outgoing :: !(Map v (Map v e))++      -- | Mapping from each vertex to its direct predecessors+      -- (possibly empty).+    , incoming :: !(Map v (Map v e))++      -- | Mapping from each vertex to its 'Level'.+      -- Invariant: If x precedes y, then x has a lower level than y.+    , levels :: !(Map v Level)+    } deriving (Eq, Show)++-- | The graph with no edges.+empty :: Graph v e+empty = Graph+    { outgoing = Map.empty+    , incoming = Map.empty+    , levels = Map.empty+    }++-- | Get all direct successors of a vertex in a 'Graph'.+getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)]+getOutgoing Graph{outgoing} x =+    map shuffle $ Map.toList $ fromMaybe Map.empty $ Map.lookup x outgoing+  where+      shuffle (x,y) = (y,x)++-- | Get all direct predecessors of a vertex in a 'Graph'.+getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)]+getIncoming Graph{incoming} x =+    Map.toList $ fromMaybe Map.empty $ Map.lookup x incoming++-- | Get the 'Level' of a vertex in a 'Graph'.+getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level+getLevel Graph{levels} x = fromMaybe ground $ Map.lookup x levels++-- | List all connected vertices,+-- i.e. vertices on which at least one edge is incident.+listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v]+listConnectedVertices Graph{incoming,outgoing} = +    Map.keys $ (() <$ outgoing) `Map.union` (() <$ incoming)++-- | Number of connected vertices,+-- i.e. vertices on which at least one edge is incident.+size :: (Eq v, Hashable v) => Graph v e -> Int+size Graph{incoming,outgoing} =+    Map.size $ (() <$ outgoing) `Map.union` (() <$ incoming)++-- | Number of edges.+edgeCount :: (Eq v, Hashable v) => Graph v e -> Int+edgeCount Graph{incoming,outgoing} =+    (count incoming + count outgoing) `div` 2+  where+    count = Map.foldl' (\a v -> Map.size v + a) 0++{-----------------------------------------------------------------------------+    Insertion+------------------------------------------------------------------------------}+-- | Insert an edge from the first to the second vertex into the 'Graph'.+insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e+insertEdge (x,y) exy g0@Graph{..} = Graph+    { outgoing+        = Map.insertWith (\new old -> new <> old) x (Map.singleton y exy)+        $ insertDefaultIfNotMember y Map.empty+        $ outgoing+    , incoming+        = Map.insertWith (\new old -> new <> old) y (Map.singleton x exy)+        . insertDefaultIfNotMember x Map.empty+        $ incoming+    , levels+        = adjustLevels+        $ levels0+    }+  where+    getLevel z = fromMaybe ground . Map.lookup z+    levels0+        = insertDefaultIfNotMember x (ground-1)+        . insertDefaultIfNotMember y ground+        $ levels++    levelDifference = getLevel y levels0 - 1 - getLevel x levels0+    adjustLevel g x = Map.adjust (+ levelDifference) x g+    adjustLevels ls+        | levelDifference >= 0 = ls+        | otherwise            = L.foldl' adjustLevel ls predecessors+      where+        Identity predecessors =+            reversePostOrder [x] (Identity . map fst . getIncoming g0)++-- Helper function: Insert a default value if the key is not a member yet+insertDefaultIfNotMember+    :: (Eq k, Hashable k)+    => k -> a -> Map k a -> Map k a+insertDefaultIfNotMember x def = Map.insertWith (\_ old -> old) x def++{-----------------------------------------------------------------------------+    Deletion+------------------------------------------------------------------------------}+-- | TODO: Not implemented.+deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e+deleteEdge (x,y) g = Graph+    { outgoing = undefined x g+    , incoming = undefined y g+    , levels = undefined+    }++-- | Remove all edges incident on this vertex from the 'Graph'.+deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e+deleteVertex x = clearLevels . clearPredecessors x . clearSuccessors x+  where+    clearLevels g@Graph{levels} = g{levels = Map.delete x levels}++-- | Remove all the edges that connect the given vertex to its predecessors.+clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e+clearPredecessors x g@Graph{..} = g+    { outgoing = foldr ($) outgoing+        [ Map.adjust (Map.delete x) z | (z,_) <- getIncoming g x ]+    , incoming = Map.delete x incoming+    }++-- | Remove all the edges that connect the given vertex to its successors.+clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e+clearSuccessors x g@Graph{..} = g+    { outgoing = Map.delete x outgoing+    , incoming = foldr ($) incoming+        [ Map.adjust (Map.delete x) z | (_,z) <- getOutgoing g x ]+    }++-- | Apply `deleteVertex` to all vertices which are not predecessors+-- of any of the vertices in the given list.+collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e+collectGarbage roots g@Graph{incoming,outgoing} = g+    { incoming = Map.filterWithKey (\v _ -> isReachable v) incoming+        -- incoming edges of reachable members are reachable by definition+    , outgoing+        = Map.map (Map.filterWithKey (\v _ -> isReachable v))+        $ Map.filterWithKey (\v _ -> isReachable v) outgoing+    }+  where+    isReachable x = x `Set.member` reachables+    reachables+        = Set.fromList . runIdentity+        $ reversePostOrder roots+        $ Identity . map fst . getIncoming g++{-----------------------------------------------------------------------------+    Topological sort+------------------------------------------------------------------------------}+-- | If the 'Graph' is acyclic, return a topological sort,+-- that is a linear ordering of its connected vertices such that+-- each vertex occurs before its successors.+--+-- (Vertices that are not connected are not listed in the topological sort.)+--+-- https://en.wikipedia.org/wiki/Topological_sorting+topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v]+topologicalSort g@Graph{incoming} =+    runIdentity $ reversePostOrder roots (Identity . map snd . getOutgoing g)+  where+    -- all vertices that have no (direct) predecessors+    roots = [ x | (x,preds) <- Map.toList incoming, null preds ]++data Step = Next | Stop++-- | Starting from a list of vertices without predecessors,+-- walk through all successors, but in such a way that every vertex+-- is visited before its predecessors.+-- For every vertex, if the function returns `Next`, then+-- the successors are visited, otherwise the walk at the vertex+-- stops prematurely.+--+-- > topologicalSort g =+-- >     runIdentity $ walkSuccessors (roots g) (pure Next) g+--+walkSuccessors+    :: forall v e m. (Monad m, Eq v, Hashable v)+    => [v] -> (v -> m Step) -> Graph v e -> m [v]+walkSuccessors xs step g = go (Q.fromList $ zipLevels xs) Set.empty []+  where+    zipLevels vs = [(getLevel g v, v) | v <- vs]++    go :: Queue Level v -> Set v -> [v] -> m [v]+    go q0 seen visits = case Q.minView q0 of+        Nothing -> pure $ reverse visits+        Just (v,q1)+            | v `Set.member` seen -> go q1 seen visits+            | otherwise -> do+                next <- step v+                let q2 = case next of+                      Stop -> q1+                      Next ->+                          let successors = zipLevels $ map snd $ getOutgoing g v+                          in  insertList q1 successors+                go q2 (Set.insert v seen) (v:visits)+++insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v+insertList = L.foldl' (\q (k,v) -> Q.insert k v q)++walkSuccessors_+    :: (Monad m, Eq v, Hashable v)+    => [v] -> (v -> m Step) -> Graph v e -> m ()+walkSuccessors_ xs step g = walkSuccessors xs step g >> pure ()++{-----------------------------------------------------------------------------+    Debugging+------------------------------------------------------------------------------}+-- | Map to a string in @graphviz@ dot file format.+showDot+    :: (Eq v, Hashable v)+    => (v -> String) -> Graph v e -> String+showDot fv g = unlines $+    [ "digraph mygraph {"+    , "  node [shape=box];"+    ] <> map showVertex (listConnectedVertices g)+    <> ["}"]+  where+    showVertex x =+        concat [ "  " <> showEdge x y <> "; " | (_,y) <- getOutgoing g x ]+    showEdge x y = escape x <> " -> " <> escape y+    escape = show . fv
+ src/Reactive/Banana/Prim/Low/GraphGC.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Low.GraphGC+    ( GraphGC+    , listReachableVertices+    , getSize+    , new+    , insertEdge+    , clearPredecessors++    , Step (..)+    , walkSuccessors+    , walkSuccessors_++    , removeGarbage+    +    -- * Debugging+    , printDot+    ) where++import Control.Applicative+    ( (<|>) )+import Control.Monad+    ( unless )+import Data.IORef+    ( IORef, atomicModifyIORef', newIORef, readIORef )+import Data.Maybe+    ( fromJust )+import Data.Unique.Really+    ( Unique )+import Reactive.Banana.Prim.Low.Graph +    ( Graph, Step )+import Reactive.Banana.Prim.Low.Ref+    ( Ref, WeakRef )++import qualified Control.Concurrent.STM as STM+import qualified Data.HashMap.Strict as Map+import qualified Reactive.Banana.Prim.Low.Graph as Graph+import qualified Reactive.Banana.Prim.Low.Ref as Ref++type Map = Map.HashMap++{-----------------------------------------------------------------------------+    GraphGC+------------------------------------------------------------------------------}+type WeakEdge v = WeakRef v++-- Graph data+data GraphD v = GraphD+    { graph :: !(Graph Unique (WeakEdge v))+    , references :: !(Map Unique (WeakRef v))+    }++{- | A directed graph whose edges are mutable+    and whose vertices are subject to garbage collection.++    The vertices of the graph are mutable references of type 'Ref v'.+    ++    Generally, the vertices of the graph are not necessarily kept reachable+    by the 'GraphGC' data structure+    — they need to be kept reachable by other parts of your program.++    That said, the edges in the graph do introduce additional reachability+    between vertices:+    Specifically, when an edge (x,y) is present in the graph,+    then the head @y@ will keep the tail @x@ reachable.+    (But the liveness of @y@ needs to come from elsewhere, e.g. another edge.)+    Use 'insertEdge' to insert an edge.++    Moreover, when a vertex is removed because it is no longer reachable,+    then all edges to and from that vertex will also be removed.+    In turn, this may cause further vertices and edges to be removed.++    Concerning garbage collection:+    Note that vertices and edges will not be removed automatically+    when the Haskell garbage collector runs —+    they will be marked as garbage by the Haskell runtime,+    but the actual removal of garbage needs+    to be done explicitly by calling 'removeGarbage'.+    This procedure makes it easier to reason about the state of the 'GraphGC'+    during a call to e.g. 'walkSuccessors'.+-}+data GraphGC v = GraphGC+    { graphRef :: IORef (GraphD v)+    , deletions :: STM.TQueue Unique+    }++-- | Create a new 'GraphGC'.+new :: IO (GraphGC v)+new = GraphGC <$> newIORef newGraphD <*> STM.newTQueueIO+  where+    newGraphD = GraphD+        { graph = Graph.empty+        , references = Map.empty+        }++getSize :: GraphGC v -> IO Int+getSize GraphGC{graphRef} = Graph.size . graph <$> readIORef graphRef++-- | List all vertices that are reachable and have at least+-- one edge incident on them.+-- TODO: Is that really what the function does?+listReachableVertices :: GraphGC v -> IO [Ref v]+listReachableVertices GraphGC{graphRef} = do+    GraphD{references} <- readIORef graphRef+    concat . Map.elems <$> traverse inspect references+  where+    inspect ref = do+        mv <- Ref.deRefWeak ref+        pure $ case mv of+            Nothing -> []+            Just r -> [r]++-- | Insert an edge from the first vertex to the second vertex.+insertEdge :: (Ref v, Ref v) -> GraphGC v -> IO ()+insertEdge (x,y) g@GraphGC{graphRef} = do+    (xKnown, yKnown) <-+        insertTheEdge =<< makeWeakPointerThatRepresentsEdge+    unless xKnown $ Ref.addFinalizer x (finalizeVertex g ux)+    unless yKnown $ Ref.addFinalizer y (finalizeVertex g uy)+  where+    ux = Ref.getUnique x+    uy = Ref.getUnique y++    makeWeakPointerThatRepresentsEdge =+        Ref.mkWeak y x Nothing++    insertTheEdge we = atomicModifyIORef' graphRef $+        \GraphD{graph,references} ->+            ( GraphD+                { graph+                    = Graph.insertEdge (ux,uy) we+                    $ graph+                , references+                    = Map.insert ux (Ref.getWeakRef x)+                    . Map.insert uy (Ref.getWeakRef y)+                    $ references+                }+            ,   ( ux `Map.member` references+                , uy `Map.member` references+                ) +            )++-- | Remove all the edges that connect the vertex to its predecessors.+clearPredecessors :: Ref v -> GraphGC v -> IO ()+clearPredecessors x GraphGC{graphRef} = do+    g <- atomicModifyIORef' graphRef $ \g -> (removeIncomingEdges g, g)+    finalizeIncomingEdges g+  where+    removeIncomingEdges g@GraphD{graph} =+        g{ graph = Graph.clearPredecessors (Ref.getUnique x) graph }+    finalizeIncomingEdges GraphD{graph} =+        mapM_ (Ref.finalize . snd) . Graph.getIncoming graph $ Ref.getUnique x++-- | Walk through all successors. See 'Graph.walkSuccessors'.+walkSuccessors+    :: Monad m+    => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m [WeakRef v])+walkSuccessors roots step GraphGC{..} = do+    GraphD{graph,references} <- readIORef graphRef+    let rootsMap = Map.fromList+            [ (Ref.getUnique r, Ref.getWeakRef r) | r <- roots ]+        fromUnique u = fromJust $+            Map.lookup u references <|> Map.lookup u rootsMap+    pure+        . fmap (map fromUnique)+        . Graph.walkSuccessors (map Ref.getUnique roots) (step . fromUnique)+        $ graph++-- | Walk through all successors. See 'Graph.walkSuccessors_'.+walkSuccessors_ ::+    Monad m => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ())+walkSuccessors_ roots step g = do+    action <- walkSuccessors roots step g+    pure $ action >> pure ()++{-----------------------------------------------------------------------------+    Garbage Collection+------------------------------------------------------------------------------}+-- | Explicitly remove all vertices and edges that have been marked+-- as garbage by the Haskell garbage collector.+removeGarbage :: GraphGC v -> IO ()+removeGarbage g@GraphGC{deletions} = do+    xs <- STM.atomically $ STM.flushTQueue deletions+    mapM_ (deleteVertex g) xs++-- Delete all edges associated with a vertex from the 'GraphGC'.+--+-- TODO: Check whether using an IORef is thread-safe.+-- I think it's fine because we have a single thread that performs deletions.+deleteVertex :: GraphGC v -> Unique -> IO ()+deleteVertex GraphGC{graphRef} x =+    atomicModifyIORef'_ graphRef $ \GraphD{graph,references} -> GraphD+        { graph = Graph.deleteVertex x graph+        , references = Map.delete x references+        }++-- Finalize a vertex+finalizeVertex :: GraphGC v -> Unique -> IO ()+finalizeVertex GraphGC{deletions} =+    STM.atomically . STM.writeTQueue deletions++{-----------------------------------------------------------------------------+    Debugging+------------------------------------------------------------------------------}+-- | Show the underlying graph in @graphviz@ dot file format.+printDot :: (Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String+printDot format GraphGC{graphRef} = do+    GraphD{graph,references} <- readIORef graphRef+    strings <- Map.traverseWithKey format references+    pure $ Graph.showDot (strings Map.!) graph++{-----------------------------------------------------------------------------+    Helper functions+------------------------------------------------------------------------------}+-- | Atomically modify an 'IORef' without returning a result.+atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef'_ ref f = atomicModifyIORef' ref $ \x -> (f x, ())
+ src/Reactive/Banana/Prim/Low/GraphTraversal.hs view
@@ -0,0 +1,41 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Low.GraphTraversal+    ( GraphM+    , reversePostOrder1+    , reversePostOrder+    ) where++import Data.Hashable+import qualified Data.HashSet as Set++{-----------------------------------------------------------------------------+    Graph traversal+------------------------------------------------------------------------------}+-- | Graph represented as map from a vertex to its direct successors.+type GraphM m a = a -> m [a]++-- | Computes the reverse post-order,+-- listing all (transitive) successor of a node.+--+-- Each vertex is listed *before* all its direct successors have been listed.+reversePostOrder1 :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]+reversePostOrder1 x = reversePostOrder [x]++-- | Reverse post-order from multiple vertices.+--+-- INVARIANT: For this to be a valid topological order,+-- none of the vertices may have a direct predecessor.+reversePostOrder :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]+reversePostOrder xs successors = 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' <- successors x+            -- visit all direct successors+            (rpo', visited') <- go xs' rpo (Set.insert x visited)+            -- prepend this vertex as all direct successors have been visited+            go xs (x:rpo') visited'
+ src/Reactive/Banana/Prim/Low/OrderedBag.hs view
@@ -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
+ src/Reactive/Banana/Prim/Low/Ref.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE UnboxedTuples #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Low.Ref+    ( -- * Mutable references with 'Unique'+      Ref+    , getUnique+    , new+    , equal+    , read+    , put+    , modify'++      -- * Garbage collection and weak pointers to 'Ref'+    , addFinalizer+    , getWeakRef++    , WeakRef+    , mkWeak+    , deRefWeak+    , deRefWeaks+    , finalize+    ) where++import Prelude hiding ( read )++import Control.DeepSeq+    ( NFData (..) )+import Control.Monad+    ( void )+import Control.Monad.IO.Class+    ( MonadIO (liftIO) )+import Data.Hashable+    ( Hashable (..) )+import Data.IORef+    ( IORef, newIORef, readIORef, writeIORef )+import Data.Maybe+    ( catMaybes )+import Data.Unique.Really+    ( Unique, newUnique )++import qualified System.Mem.Weak as Weak+import qualified GHC.Base as GHC+import qualified GHC.IORef as GHC+import qualified GHC.STRef as GHC+import qualified GHC.Weak as GHC++{-----------------------------------------------------------------------------+    Ref+------------------------------------------------------------------------------}+-- | A mutable reference which has a 'Unique' associated with it.+data Ref a = Ref+    !Unique         -- Unique associated to the 'Ref'+    !(IORef a)      -- 'IORef' that stores the value of type 'a'+    !(WeakRef a)    -- For convenience, a weak pointer to itself++instance NFData (Ref a) where rnf (Ref _ _ _) = ()++instance Eq (Ref a) where (==) = equal++instance Hashable (Ref a) where hashWithSalt s (Ref u _ _) = hashWithSalt s u++getUnique :: Ref a -> Unique+getUnique (Ref u _ _) = u++getWeakRef :: Ref a -> WeakRef a+getWeakRef (Ref _ _ w) = w++equal :: Ref a -> Ref b -> Bool+equal (Ref ua _ _) (Ref ub _ _) = ua == ub++new :: MonadIO m => a -> m (Ref a)+new a = liftIO $ mdo+    ra     <- newIORef a+    result <- Ref <$> newUnique <*> pure ra <*> pure wa+    wa     <- mkWeakIORef ra result Nothing+    pure result++read :: MonadIO m => Ref a -> m a+read ~(Ref _ r _) = liftIO $ readIORef r++put :: MonadIO m => Ref a -> a -> m ()+put ~(Ref _ r _) = liftIO . writeIORef r++-- | Strictly modify a 'Ref'.+modify' :: MonadIO m => Ref a -> (a -> a) -> m ()+modify' ~(Ref _ r _) f = liftIO $+    readIORef r >>= \x -> writeIORef r $! f x++{-----------------------------------------------------------------------------+    Weak pointers+------------------------------------------------------------------------------}+-- | Add a finalizer to a 'Ref'.+--+-- See 'System.Mem.Weak.addFinalizer'.+addFinalizer :: Ref v -> IO () -> IO ()+addFinalizer (Ref _ r _) = void . mkWeakIORef r () . Just++-- | Weak pointer to a 'Ref'.+type WeakRef v = Weak.Weak (Ref v)++-- | Create a weak pointer that associates a key with a value.+--+-- See 'System.Mem.Weak.mkWeak'.+mkWeak+    :: Ref k -- ^ key+    -> v -- ^ value+    -> Maybe (IO ()) -- ^ finalizer+    -> IO (Weak.Weak v)+mkWeak (Ref _ r _) = mkWeakIORef r++-- | Finalize a 'WeakRef'.+--+-- See 'System.Mem.Weak.finalize'.+finalize :: WeakRef v -> IO ()+finalize = Weak.finalize++-- | Dereference a 'WeakRef'.+--+-- See 'System.Mem.Weak.deRefWeak'.+deRefWeak :: Weak.Weak v -> IO (Maybe v)+deRefWeak = Weak.deRefWeak++-- | Dereference a list of weak pointers while discarding dead ones.+deRefWeaks :: [Weak.Weak v] -> IO [v]+deRefWeaks ws = catMaybes <$> mapM Weak.deRefWeak ws++{-----------------------------------------------------------------------------+    Helpers+------------------------------------------------------------------------------}+-- | Create a weak pointer to an 'IORef'.+--+-- Unpacking the constructors (e.g. 'GHC.IORef' etc.) is necessary+-- because the constructors may be unpacked while the 'IORef' is used+-- — so, the value contained therein is alive, but the constructors are not.+mkWeakIORef+    :: IORef k -- ^ key+    -> v       -- ^ value+    -> Maybe (IO ()) -- ^ finalizer+    -> IO (Weak.Weak v)+mkWeakIORef (GHC.IORef (GHC.STRef r#)) v (Just (GHC.IO finalizer)) =+    GHC.IO $ \s -> case GHC.mkWeak# r# v finalizer s of+        (# s1, w #) -> (# s1, GHC.Weak w #)+mkWeakIORef (GHC.IORef (GHC.STRef r#)) v Nothing =+    GHC.IO $ \s -> case GHC.mkWeakNoFinalizer# r# v s of+        (# s1, w #) -> (# s1, GHC.Weak w #)
+ src/Reactive/Banana/Prim/Mid.hs view
@@ -0,0 +1,116 @@+{-----------------------------------------------------------------------------+    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, EvalNetwork, Network, emptyNetwork, getSize,++    -- * 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+    +    -- * Debugging+    printDot+  ) where+++import Control.Monad.IO.Class+import Reactive.Banana.Prim.Mid.Combinators+import Reactive.Banana.Prim.Mid.Compile+import Reactive.Banana.Prim.Mid.IO+import Reactive.Banana.Prim.Mid.Plumbing+    ( neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater )+import Reactive.Banana.Prim.Mid.Types+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.++-}
+ src/Reactive/Banana/Prim/Mid/Combinators.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.Combinators where++import Control.Monad+    ( join )+import Control.Monad.IO.Class+    ( liftIO )++import Reactive.Banana.Prim.Mid.Plumbing+    ( newPulse, newLatch, cachedLatch+    , dependOn, keepAlive, changeParent+    , getValueL+    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,+    )+import qualified Reactive.Banana.Prim.Mid.Plumbing+    ( pureL )+import Reactive.Banana.Prim.Mid.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.Mid.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 <- newPulse "accumL" $ do+      a <- readLatchP x+      f <- readPulseP p1+      return $ fmap (\g -> g a) f+    p2 `dependOn` 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 = do+    -- track the latest Pulse in a Latch+    lp <- stepperL p pp++    -- fetch the latest Pulse value+    pout <- newPulse "switchP_out" (readPulseP =<< readLatchP lp)++    let -- switch the Pulse `pout` to a new parent,+        -- keeping track of the new dependencies.+        switch = do+            mnew <- readPulseP pp+            case mnew of+                Nothing  -> pure ()+                Just new -> liftBuildP $ pout `changeParent` new+            pure Nothing++    pin <- newPulse "switchP_in" switch :: Build (Pulse ())+    pin  `dependOn` pp+    +    pout `dependOn` p       -- initial dependency+    pout `keepAlive` pin    -- keep switches happening+    pure pout
+ src/Reactive/Banana/Prim/Mid/Compile.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.Compile where++import Control.Exception+    ( evaluate )+import Data.Functor+    ( void )+import Data.IORef+    ( newIORef, readIORef, writeIORef )++import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC+import qualified Reactive.Banana.Prim.Low.OrderedBag as OB+import           Reactive.Banana.Prim.Mid.Combinators (mapP)+import           Reactive.Banana.Prim.Mid.Evaluation (applyDependencyChanges)+import           Reactive.Banana.Prim.Mid.IO+import           Reactive.Banana.Prim.Mid.Plumbing+import           Reactive.Banana.Prim.Mid.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, nGraphGC} = do+    (a, dependencyChanges, os) <- runBuildIO (nTime, nAlwaysP) m++    applyDependencyChanges dependencyChanges nGraphGC+    let state2 = Network+            { nTime    = next nTime+            , nOutputs = OB.inserts nOutputs os+            , nAlwaysP+            , nGraphGC+            }+    return (a,state2)++emptyNetwork :: IO Network+emptyNetwork = do+  (alwaysP, _, _) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())+  nGraphGC <- GraphGC.new+  pure Network+    { nTime    = next beginning+    , nOutputs = OB.empty+    , nAlwaysP = alwaysP+    , nGraphGC+    }++{-----------------------------------------------------------------------------+    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)++    fst <$> 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],s)+mapAccumM f s0 = go s0 []+  where+    go s1 bs []     = pure (reverse bs,s1)+    go s1 bs (x:xs) = do+        (b,s2) <- f x s1+        go s2 (b:bs) xs++-- | 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
+ src/Reactive/Banana/Prim/Mid/Evaluation.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.Evaluation+    ( step+    , applyDependencyChanges+    ) where++import Control.Monad+    ( join )+import Control.Monad.IO.Class+    ( liftIO )++import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC+import qualified Reactive.Banana.Prim.Low.OrderedBag as OB+import qualified Reactive.Banana.Prim.Low.Ref as Ref+import           Reactive.Banana.Prim.Mid.Plumbing+import           Reactive.Banana.Prim.Mid.Types++{-----------------------------------------------------------------------------+    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+        , nGraphGC+        }+    = do++    -- evaluate pulses+    ((_, (latchUpdates, outputs)), dependencyChanges, os)+            <- runBuildIO (time1, alwaysP)+            $  runEvalP pulses+            $  evaluatePulses inputs nGraphGC++    doit latchUpdates                          -- update latch values from pulses+    applyDependencyChanges dependencyChanges   -- rearrange graph topology+        nGraphGC+    GraphGC.removeGarbage nGraphGC             -- remove unreachable pulses+    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+            , nGraphGC+            }+    return (runEvalOs $ map snd actions, state2)++runEvalOs :: [EvalO] -> IO ()+runEvalOs = mapM_ join++{-----------------------------------------------------------------------------+    Dependency changes+------------------------------------------------------------------------------}+-- | Apply all dependency changes to the 'GraphGC'.+applyDependencyChanges :: DependencyChanges -> Dependencies -> IO ()+applyDependencyChanges changes g = do+    sequence_ [applyDependencyChange c g | c@(InsertEdge _ _) <- changes]+    sequence_ [applyDependencyChange c g | c@(ChangeParentTo _ _) <- changes]++applyDependencyChange+    :: DependencyChange SomeNode SomeNode -> Dependencies -> IO ()+applyDependencyChange (InsertEdge parent child) g =+    GraphGC.insertEdge (parent, child) g+applyDependencyChange (ChangeParentTo child parent) g = do+    GraphGC.clearPredecessors child g+    GraphGC.insertEdge (parent, child) g++{-----------------------------------------------------------------------------+    Traversal in dependency order+------------------------------------------------------------------------------}+-- | Update all pulses in the graph, starting from a given set of nodes+evaluatePulses :: [SomeNode] -> Dependencies -> EvalP ()+evaluatePulses inputs g = do+    action <- liftIO $ GraphGC.walkSuccessors_ inputs evaluateWeakNode g+    action++evaluateWeakNode :: Ref.WeakRef SomeNodeD -> EvalP GraphGC.Step+evaluateWeakNode w = do+    mnode <- liftIO $ Ref.deRefWeak w+    case mnode of+        Nothing -> pure GraphGC.Stop+        Just node -> evaluateNode node++-- | Recalculate a given node and return all children nodes+-- that need to evaluated subsequently.+evaluateNode :: SomeNode -> EvalP GraphGC.Step+evaluateNode someNode = do+    node <- Ref.read someNode+    case node of+        P PulseD{_evalP,_keyP} -> {-# SCC evaluateNodeP #-} do+            ma <- _evalP+            writePulseP _keyP ma+            pure $ case ma of+                Nothing -> GraphGC.Stop+                Just _  -> GraphGC.Next+        L lw -> {-# SCC evaluateLatchWrite #-} do+            evaluateLatchWrite lw+            pure GraphGC.Stop+        O o -> {-# SCC evaluateNodeO #-} do+            m <- _evalO o -- calculate output action+            rememberOutput (someNode,m)+            pure GraphGC.Stop++evaluateLatchWrite :: LatchWriteD -> EvalP ()+evaluateLatchWrite LatchWriteD{_evalLW,_latchLW} = do+    time   <- askTime+    mlatch <- liftIO $ Ref.deRefWeak _latchLW -- retrieve destination latch+    case mlatch of+        Nothing    -> pure ()+        Just latch -> do+            a <- _evalLW                    -- calculate new latch value+            -- liftIO $ Strict.evaluate a   -- see Note [LatchStrictness]+            rememberLatchUpdate $           -- schedule value to be set later+                Ref.modify' latch $ \l ->+                    a `seq` l { _seenL = time, _valueL = a }
+ src/Reactive/Banana/Prim/Mid/IO.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.IO where++import Control.Monad.IO.Class+    ( liftIO )+import qualified Data.Vault.Lazy        as Lazy++import Reactive.Banana.Prim.Mid.Combinators (mapP)+import Reactive.Banana.Prim.Mid.Evaluation  (step)+import Reactive.Banana.Prim.Mid.Plumbing+import Reactive.Banana.Prim.Mid.Types+import qualified Reactive.Banana.Prim.Low.Ref as Ref++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+    nodeP  <- liftIO $ Ref.new $ P $ PulseD+        { _keyP      = _key+        , _seenP     = agesAgo+        , _evalP     = readPulseP pulse    -- get its own value+        , _nameP     = "newInput"+        }+    let pulse = Pulse{_key,_nodeP=nodeP}+    -- Also add the  alwaysP  pulse to the inputs.+    let run :: a -> Step+        run a = step ([nodeP, _nodeP always], Lazy.insert _key (Just a) Lazy.empty)+    pure (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
+ src/Reactive/Banana/Prim/Mid/Plumbing.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.Plumbing where++import Control.Monad+    ( join, void )+import Control.Monad.IO.Class+    ( liftIO )+import Data.IORef+    ( newIORef, writeIORef, readIORef )+import Data.Maybe+    ( fromMaybe )+import System.IO.Unsafe+    ( unsafePerformIO, unsafeInterleaveIO )++import qualified Control.Monad.Trans.RWSIO          as RWS+import qualified Control.Monad.Trans.ReaderWriterIO as RW+import qualified Data.Vault.Lazy                    as Lazy++import qualified Reactive.Banana.Prim.Low.Ref as Ref+import           Reactive.Banana.Prim.Mid.Types++{-----------------------------------------------------------------------------+    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+    _nodeP <- Ref.new $ P $ PulseD+        { _keyP      = _key+        , _seenP     = agesAgo+        , _evalP     = eval+        , _nameP     = name+        }+    pure $ Pulse{_key,_nodeP}++{-+* 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+    _nodeP <- Ref.new $ P $ PulseD+        { _keyP      = _key+        , _seenP     = agesAgo+        , _evalP     = pure Nothing+        , _nameP     = "neverP"+        }+    pure $ Pulse{_key,_nodeP}++-- | Return a 'Latch' that has a constant value+pureL :: a -> Latch a+pureL a = unsafePerformIO $ Ref.new $ 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 = do+    latch <- liftIO $ mdo+        latch <- Ref.new $ Latch+            { _seenL  = beginning+            , _valueL = a+            , _evalL  = do+                Latch {..} <- Ref.read latch+                RW.tell _seenL  -- indicate timestamp+                return _valueL  -- indicate value+            }+        pure latch++    let+        err        = error "incorrect Latch write"++        updateOn :: Pulse a -> Build ()+        updateOn p = do+            w  <- liftIO $ Ref.mkWeak latch latch Nothing+            lw <- liftIO $ Ref.new $ L $ LatchWriteD+                { _evalLW  = fromMaybe err <$> readPulseP p+                , _latchLW = w+                }+            -- writer is alive only as long as the latch is alive+            _  <- liftIO $ Ref.mkWeak latch lw Nothing+            _nodeP p `addChild` lw++    return (updateOn, latch)++-- | Make a new 'Latch' that caches a previous computation.+cachedLatch :: EvalL a -> Latch a+cachedLatch eval = unsafePerformIO $ mdo+    latch <- Ref.new $ Latch+        { _seenL  = agesAgo+        , _valueL = error "Undefined value of a cached latch."+        , _evalL  = do+            Latch{..} <- liftIO $ Ref.read 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` Ref.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 $ Ref.new $ O $ Output+        { _evalO = fromMaybe (pure $ pure ()) <$> readPulseP p+        }+    _nodeP p `addChild` o+    RW.tell $ BuildW (mempty, [o], mempty, mempty)++{-----------------------------------------------------------------------------+    Build monad+------------------------------------------------------------------------------}+runBuildIO :: BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])+runBuildIO i m = do+    (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m+    doit liftIOLaters          -- execute late IOs+    return (a,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 = _nodeP parent `addChild` _nodeP child++keepAlive :: Pulse child -> Pulse parent -> Build ()+keepAlive child parent = liftIO $ void $+    Ref.mkWeak (_nodeP child) (_nodeP parent) Nothing++addChild :: SomeNode -> SomeNode -> Build ()+addChild parent child =+    RW.tell $ BuildW ([InsertEdge parent child], mempty, mempty, mempty)++changeParent :: Pulse child -> Pulse parent -> Build ()+changeParent pulse0 parent0 =+    RW.tell $ BuildW ([ChangeParentTo pulse parent], mempty, mempty, mempty)+   where+     pulse = _nodeP pulse0+     parent = _nodeP parent0++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{..} <- Ref.read latch+    liftIO $ fst <$> RW.runReaderWriterIOT _evalL ()++getValueL :: Latch a -> EvalL a+getValueL latch = do+    Latch{..} <- Ref.read 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 Pulse{_key} =+    join . Lazy.lookup _key <$> 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
+ src/Reactive/Banana/Prim/Mid/Test.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RecursiveDo #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+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)]
+ src/Reactive/Banana/Prim/Mid/Types.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Prim.Mid.Types where++import Data.Hashable+    ( hashWithSalt )+import Data.Unique.Really+    ( Unique )+import Control.Monad.Trans.RWSIO+    ( RWSIOT )+import Control.Monad.Trans.ReaderWriterIO+    ( ReaderWriterIOT )+import Reactive.Banana.Prim.Low.OrderedBag+    ( OrderedBag )+import System.IO.Unsafe+    ( unsafePerformIO )+import System.Mem.Weak+    ( Weak )++import qualified Data.Vault.Lazy as Lazy+import qualified Reactive.Banana.Prim.Low.Ref as Ref+import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC++{-----------------------------------------------------------------------------+    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.+    , nGraphGC        :: Dependencies+    }++getSize :: Network -> IO Int+getSize = GraphGC.getSize . nGraphGC++type Dependencies  = GraphGC.GraphGC SomeNodeD+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 (DependencyChanges, [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++data DependencyChange parent child+    = InsertEdge parent child+    | ChangeParentTo child parent+type DependencyChanges = [DependencyChange SomeNode SomeNode]++{-----------------------------------------------------------------------------+    Synonyms+------------------------------------------------------------------------------}+-- | '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 = (<>)++{-----------------------------------------------------------------------------+    Pulse and Latch+------------------------------------------------------------------------------}+data Pulse a = Pulse+    { _key :: Lazy.Key (Maybe a) -- Key to retrieve pulse value from cache.+    , _nodeP :: SomeNode         -- Reference to its own node+    }++data PulseD a = PulseD+    { _keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.+    , _seenP     :: !Time              -- See note [Timestamp].+    , _evalP     :: EvalP (Maybe a)    -- Calculate current value.+    , _nameP     :: String             -- Name for debugging.+    }++instance Show (Pulse a) where+    show p = name <> " " <> show (hashWithSalt 0 $ _nodeP p)+      where+        name = case unsafePerformIO $ Ref.read $ _nodeP p of+              P pulseD -> _nameP pulseD+              _ -> ""++showUnique :: Unique -> String+showUnique = show . hashWithSalt 0++type Latch  a = Ref.Ref (LatchD a)+data LatchD a = Latch+    { _seenL  :: !Time               -- Timestamp for the current value.+    , _valueL :: a                   -- Current value.+    , _evalL  :: EvalL a             -- Recalculate current latch value.+    }++type LatchWrite = SomeNode+data LatchWriteD = forall a. LatchWriteD+    { _evalLW  :: EvalP a            -- Calculate value to write.+    , _latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.+    }++type Output  = SomeNode+data OutputD = Output+    { _evalO     :: EvalP EvalO+    }++type SomeNode = Ref.Ref SomeNodeD+data SomeNodeD+    = forall a. P (PulseD a)+    | L LatchWriteD+    | O OutputD++{-# INLINE mkWeakNodeValue #-}+mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)+mkWeakNodeValue x v = Ref.mkWeak x v Nothing++-- | 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 node = do+    someNode <- Ref.read node+    pure $ case someNode of+        P p -> _nameP p+        L _ -> "L"+        O _ -> "O"++-- | Show the graph of the 'Network' in @graphviz@ dot file format.+printDot :: Network -> IO String+printDot = GraphGC.printDot format . nGraphGC+  where+    format u weakref = do+         mnode <- Ref.deRefWeak weakref+         ((showUnique u <> ": ") <>) <$> case mnode of+             Nothing -> pure "(x_x)"+             Just node -> printNode node++{-----------------------------------------------------------------------------+    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`.++-}
− src/Reactive/Banana/Switch.hs 
@@ -1,94 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances #-}--module Reactive.Banana.Switch (-    -- * Synopsis-    -- | Dynamic event switching.-    -    -- * Moment monad-    Moment, AnyMoment, anyMoment, now,-    -    -- * Dynamic event switching-    trimE, trimB,-    switchE, switchB,-    observeE, valueB,-    -    -- * Identity Functor-    Identity(..),-    ) where--import Control.Applicative-import Control.Monad--import Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2--{------------------------------------------------------------------------------    Constant-------------------------------------------------------------------------------}--- | Identity functor with a dummy argument.--- Unlike 'Data.Functor.Constant',--- this functor is constant in the /second/ argument.--newtype Identity t a = Identity { getIdentity :: a }--instance Functor (Identity t) where-    fmap f (Identity a) = Identity (f a)--{------------------------------------------------------------------------------    Moment-------------------------------------------------------------------------------}--- | Value present at any/every moment in time.-newtype AnyMoment f a = AnyMoment { now :: forall t. Moment t (f t a) }--instance Monad (AnyMoment Identity) where-    return x = AnyMoment $ return (Identity x)-    (AnyMoment m) >>= g = AnyMoment $ m >>= \(Identity x) -> now (g x)--instance Functor (AnyMoment Behavior) where-    fmap f (AnyMoment x) = AnyMoment (fmap (fmap f) x)--instance Applicative (AnyMoment Behavior) where-    pure x  = AnyMoment $ return $ pure x-    (AnyMoment f) <*> (AnyMoment x) = AnyMoment $ liftM2 (<*>) f x--anyMoment :: (forall t. Moment t (f t a)) -> AnyMoment f a-anyMoment = AnyMoment--{------------------------------------------------------------------------------    Dynamic event switching-------------------------------------------------------------------------------}--- | Trim an 'Event' to a variable start time.-trimE :: Event t a -> Moment t (AnyMoment Event a)-trimE = M . fmap (\x -> AnyMoment (M $ fmap E x)) . Prim.trimE . unE---- | Trim a 'Behavior' to a variable start time.-trimB :: Behavior t a -> Moment t (AnyMoment Behavior a)-trimB = M . fmap (\x -> AnyMoment (M $ fmap B x)) . Prim.trimB . unB---- | Observe a value at those moments in time where--- event occurrences happen.-observeE :: Event t (AnyMoment Identity a) -> Event t a-observeE = E . Prim.observeE-    . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE---- | Obtain the value of the 'Behavior' at moment @t@.-valueB :: Behavior t a -> Moment t a-valueB = M . Prim.initialB . unB---- | Dynamically switch between 'Event'.-switchE-    :: forall t a. Event t (AnyMoment Event a)-    -> Event t a-switchE = E . Prim.switchE . Prim.mapE (fmap unE . unM . now . last) . unE---- | Dynamically switch between 'Behavior'.-switchB-    :: forall t a. Behavior t a-    -> Event t (AnyMoment Behavior a)-    -> Behavior t a-switchB b e = B $ Prim.switchB (unB b) $-    Prim.mapE (fmap unB . unM . now . last) (unE e)
− src/Reactive/Banana/Test.hs 
@@ -1,168 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Test cases and examples-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}--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-        , testModelMatch "accumE1" accumE1-        ]-    , testGroup "Complex"-        [ testModelMatch "counter"    counter-        , testModelMatch "double"     double-        , testModelMatch "sharing"    sharing-        , testModelMatch "recursive1" recursive1-        , testModelMatch "recursive2" recursive2-        , testModelMatch "recursive3" recursive3-        , testModelMatch "accumBvsE"  accumBvsE-        ]-    , testGroup "Dynamic Event Switching"-        [ testModelMatch  "observeE_id"         observeE_id-        , testModelMatchM "initialB_immediate"  initialB_immediate-        , testModelMatchM "initialB_recursive1" initialB_recursive1-        , testModelMatchM "initialB_recursive2" initialB_recursive2-        , testModelMatchM "dynamic_apply"       dynamic_apply-        , testModelMatchM "switchE1"            switchE1-        , testModelMatchM "switchB_two"         switchB_two-        ]-    -- 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 = applyE (pure const <*> bcounter) e-    where bcounter = accumB 0 $ fmap (\_ -> (+1)) e--merge e1 e2 = unionWith (++) (list e1) (list e2)-    where list = fmap (:[])-    -double e  = merge e e-sharing e = merge e1 e1-    where e1 = filterE (< 3) e-recursive1 e1 = e2-    where-    e2 = applyE b e1-    b  = (+) <$> stepperB 0 e2-recursive2 e1 = e2-    where-    e2 = applyE b e1-    b  = (+) <$> stepperB 0 e3-    e3 = applyE (id <$> b) e1   -- actually equal to e2--type Dummy = Int---- counter that can be decreased as long as it's >= 0-recursive3 :: Event Dummy -> Event Int-recursive3 edec = applyE (const <$> bcounter) ecandecrease-    where-    bcounter     = accumB 4 $ (subtract 1) <$ ecandecrease-    ecandecrease = whenE ((>0) <$> bcounter) edec---- test accumE vs accumB-accumBvsE :: Event Dummy -> Event [Int]-accumBvsE e = merge e1 e2-    where-    e1 = accumE 0 ((+1) <$ e)-    e2 = let b = accumB 0 ((+1) <$ e) in applyE (const <$> b) e---observeE_id = observeE . fmap return -- = id--initialB_immediate e = do-    x <- initialB (stepper 0 e)-    return $ x <$ e-initialB_recursive1 e1 = mdo-    _ <- initialB b-    let b = stepper 0 e1-    return $ b <@ e1-    --- NOTE: This test case tries to reproduce a situation--- where the value of a latch is used before the latch was created.--- This was relevant for the CRUD example, but I can't find a way--- to make it smaller right now. Oh well.-initialB_recursive2 e1 = mdo-    x <- initialB b-    let bf = const x <$ stepper 0 e1 -    let b  = stepper 0 $ (bf <*> b) <@ e1-    return $ b <@ e1--dynamic_apply e = do-    mb <- trimB $ stepper 0 e-    return $ observeE $ (initialB =<< mb) <$ e-    -- = stepper 0 e <@ e-switchE1 e = do-    me <- trimE e-    return $ switchE $ me <$ e-switchB_two e = do-    mb0 <- trimB $ stepper 0 $ filterE even e-    mb1 <- trimB $ stepper 1 $ filterE odd  e-    b0  <- mb0-    let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e-    return $ b <@ e
− src/Reactive/Banana/Test/Plumbing.hs 
@@ -1,102 +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)-import Control.Monad.Fix--import qualified Reactive.Banana.Model as X-import qualified Reactive.Banana.Internal.EventBehavior1 as Y-import qualified Reactive.Banana.Internal.InputOutput 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)-unionWith f (E x1 y1) (E x2 y2) = E (X.unionWith f x1 x2) (Y.unionWith f y1 y2)-mapE f (E x y)                  = E (X.mapE f x) (Y.mapE f y)-applyE ~(B x1 y1) (E x2 y2)     = E (X.applyE x1 x2) (Y.applyE y1 y2)-accumE a (E x y)                = E (X.accumE a x) (Y.accumE a y)--instance Functor Event where fmap = mapE--stepper = stepperB-stepperB a (E x y)              = B (X.stepperB a x) (Y.stepperB a y)-pureB a                         = B (X.pureB a) (Y.pureB a)-applyB (B x1 y1) (B x2 y2)      = B (X.applyB x1 x2) (Y.applyB y1 y2)-mapB f (B x y)                  = B (X.mapB 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 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--trimE :: Event a -> Moment (Moment (Event a))-trimE (E x y) = M-    (fmap (fmap ex . mx) $ X.trimE x)-    (fmap (fmap ey . my) $ Y.trimE y)-trimB :: Behavior a -> Moment (Moment (Behavior a))-trimB (B x y) = M-    (fmap (fmap bx . mx) $ X.trimB x)-    (fmap (fmap by . my) $ Y.trimB y)--initialB ~(B x y) = M (X.initialB x) (Y.initialB y)--observeE :: Event (Moment a) -> Event a-observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y)--switchE :: Event (Moment (Event a)) -> Event a-switchE (E x y) = E-    (X.switchE $ X.mapE (fstM . fmap fstE) x)-    (Y.switchE $ Y.mapE (sndM . fmap sndE) y)--switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a-switchB (B x y) (E xe ye) = B-    (X.switchB x $ X.mapE (fstM . fmap fstB) xe)-    (Y.switchB y $ Y.mapE (sndM . fmap sndB) ye)--{------------------------------------------------------------------------------    Derived combinators-------------------------------------------------------------------------------}-accumB acc = stepperB acc . accumE acc-whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)-b <@ e = applyE (const <$> b) e
+ src/Reactive/Banana/Types.hs view
@@ -0,0 +1,249 @@+{-# language CPP #-}++{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Types (+    -- | Primitive types.+    Event(..), Behavior(..),+    Moment(..), MomentIO(..), MonadMoment(..),+    Future(..),+    ) where++import Control.Applicative+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)++#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+------------------------------------------------------------------------------}++{-| @Event a@ represents a stream of events as they occur in time.+Semantically, you can think of @Event a@ as an infinite list of values+that are tagged with their corresponding time of occurrence,++> type Event a = [(Time,a)]++Each pair is called an /event occurrence/.+Note that within a single event stream,+no two event occurrences may happen at the same time.++<<doc/frp-event.png>>+-}+newtype Event a = E { unE :: Prim.Event a }+-- Invariant: The empty list `[]` never occurs as event value.++-- | The function 'fmap' applies a function @f@ to every value.+-- Semantically,+--+-- > fmap :: (a -> b) -> Event a -> Event b+-- > fmap f e = [(time, f a) | (time, a) <- e]+instance Functor Event where+    fmap f = E . Prim.mapE f . unE++-- | The combinator '<>' merges two event streams of the same type.+-- In case of simultaneous occurrences,+-- the events are combined with the underlying 'Semigroup' operation.+-- Semantically,+--+-- > (<>) :: Event a -> Event a -> Event a+-- > (<>) ex ey = unionWith (<>) ex ey+instance Semigroup a => Semigroup (Event a) where+    x <> y = E $ Prim.mergeWith id id (<>) (unE x) (unE y)++-- | The combinator 'mempty' represents an event that never occurs.+-- It is a synonym,+--+-- > mempty :: Event a+-- > mempty = never+instance Semigroup a => Monoid (Event a) where+    mempty  = E Prim.never+    mappend = (<>)+++{-| @Behavior a@ represents a value that varies in time.+Semantically, you can think of it as a function++> type Behavior a = Time -> a++<<doc/frp-behavior.png>>+-}+newtype Behavior a = B { unB :: Prim.Behavior a }++-- | The function 'pure' returns a value that is constant in time. Semantically,+--+-- > pure     :: a -> Behavior a+-- > pure x    = \time -> x+--+-- The combinator '<*>' applies a time-varying function to a time-varying value.+--+-- > (<*>)    :: Behavior (a -> b) -> Behavior a -> Behavior b+-- > fx <*> bx = \time -> fx time $ bx time+instance Applicative Behavior where+    pure x    = B $ Prim.pureB x+    bf <*> bx = B $ Prim.applyB (unB bf) (unB bx)++-- | The function 'fmap' applies a function @f@ at every point in time.+-- Semantically,+--+-- > fmap :: (a -> b) -> Behavior a -> Behavior b+-- > fmap f b = \time -> f (b time)+instance Functor Behavior where+    fmap = liftA++instance Semigroup a => Semigroup (Behavior a) where+  (<>) = liftA2 (<>)++instance (Semigroup a, Monoid a) => Monoid (Behavior a) where+  mempty = pure mempty+  mappend = (<>)++instance Num a => Num (Behavior a) where+    (+) = liftA2 (+)+    (-) = liftA2 (-)+    (*) = liftA2 (*)+    abs = fmap abs+    signum = fmap signum+    fromInteger = pure . fromInteger+    negate = fmap negate++instance Fractional a => Fractional (Behavior a) where+    (/) = liftA2 (/)+    fromRational = pure . fromRational+    recip = fmap recip++instance Floating a => Floating (Behavior a) where+    (**) = liftA2 (**)+    acos = fmap acos+    acosh = fmap acosh+    asin = fmap asin+    asinh = fmap asinh+    atan = fmap atan+    atanh = fmap atanh+    cos = fmap cos+    cosh = fmap cosh+    exp = fmap exp+    log = fmap log+    logBase = liftA2 logBase+    pi = pure pi+    sin = fmap sin+    sinh = fmap sinh+    sqrt = fmap sqrt++instance IsString a => IsString (Behavior a) where+    fromString = pure . fromString++-- | The 'Future' monad is just a helper type for the 'changes' function.+--+-- A value of type @Future a@ is only available in the context+-- of a 'reactimate' but not during event processing.+newtype Future a = F { unF :: Prim.Future a }++-- boilerplate class instances+instance Functor Future where fmap f = F . fmap f . unF++instance Monad Future where+    m >>= g = F $ unF m >>= unF . g++instance Applicative Future where+    pure    = F . pure+    f <*> a = F $ unF f <*> unF a+++{-| The 'Moment' monad denotes a /pure/ computation that happens+at one particular moment in time. Semantically, it is a reader monad++> type Moment a = Time -> a++When run, the argument tells the time at which this computation happens.++Note that in this context, /time/ really means to /logical time/.+Of course, every calculation on a computer takes some+amount of wall-clock time to complete.+Instead, what is meant here is the time as it relates to+'Event's and 'Behavior's.+We use the fiction that every calculation within the 'Moment'+monad takes zero /logical time/ to perform.+-}+newtype Moment a = M { unM :: Prim.Moment a }++{-| The 'MomentIO' monad is used to add inputs and outputs+to an event network.+-}+newtype MomentIO a = MIO { unMIO :: Prim.Moment a }++instance MonadIO MomentIO where liftIO = MIO . liftIO++{-| An instance of the 'MonadMoment' class denotes a computation+that happens at one particular moment in time.+Unlike the 'Moment' monad, it need not be pure anymore.+-}+class MonadFix m => MonadMoment m where+    liftMoment :: Moment a -> m a++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+    m >>= g = M $ unM m >>= unM . g+instance Applicative Moment where+    pure    = M . pure+    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+    m >>= g = MIO $ unMIO m >>= unMIO . g+instance Applicative MomentIO where+    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
+ test/Reactive/Banana/Test/High/Combinators.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Exemplar test for various high-level combinators.+module Reactive.Banana.Test.High.Combinators+    ( tests+    ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+    ( when, join )+import Test.Tasty+    ( defaultMain, testGroup, TestTree )+import Test.Tasty.HUnit+    ( testCase, assertBool )++import Reactive.Banana.Test.High.Plumbing++tests :: TestTree+tests = testGroup "Combinators, high level"+    [ 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+
+ test/Reactive/Banana/Test/High/Plumbing.hs view
@@ -0,0 +1,104 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- * Synopsis+-- | Merge model and implementation into a single type. Not pretty.+module Reactive.Banana.Test.High.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 a = M (pure a) (pure a)+    (<*>) = ap+instance Monad Moment where+    ~(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
+ test/Reactive/Banana/Test/High/Space.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE RecursiveDo #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Exemplar tests for space usage and garbage collection.+module Reactive.Banana.Test.High.Space where++import Control.Monad+    ( forM )+import Test.Tasty+    ( testGroup, TestTree )+import Test.Tasty.QuickCheck+    ( testProperty )++import qualified Test.QuickCheck as Q+import qualified Test.QuickCheck.Monadic as Q++import qualified Control.Exception as Memory+import qualified Control.Concurrent as System+import qualified System.Mem as System++import Reactive.Banana+import Reactive.Banana.Frameworks++tests :: TestTree+tests = testGroup "Space usage, high level"+    [ testGroup "Network size stays bounded"+        [ testBoundedNetworkSize "execute" execute1+        , testBoundedNetworkSize "observe accumE, issue #261" observeAccumE1+        , testBoundedNetworkSize "execute accumE, issue #261" executeAccumE1+        , testBoundedNetworkSize "switch accumE, issue #261" switchAccumE1+        ]+    ]++{-----------------------------------------------------------------------------+    Tests+------------------------------------------------------------------------------}+execute1 :: Event Int -> MomentIO (Event (Event Int))+execute1 e = execute $ (\i -> liftIO $ Memory.evaluate (i <$ e)) <$> e++observeAccumE1 :: Event Int -> MomentIO (Event (Event ()))+observeAccumE1 e = pure $ observeE (accumE () never <$ e)++executeAccumE1 :: Event Int -> MomentIO (Event (Event ()))+executeAccumE1 e = execute (accumE () (id <$ e) <$ e)++switchAccumE1 :: Event Int -> MomentIO (Event ())+switchAccumE1 e = do+    let e2 :: Event (Event ())+        e2 = observeE (accumE () (id <$ e) <$ e)+    switchE never e2++{-----------------------------------------------------------------------------+    Test harness+------------------------------------------------------------------------------}+-- | Execute an FRP network with a sequence of inputs+-- with intermittend of garbage collection and record network sizes.+runNetworkSizes+    :: (Event a -> MomentIO (Event ignore))+    -> [a] -> IO [Int]+runNetworkSizes f xs = do+    (network, fire) <- setup+    run network fire+  where+    setup = do+        (ah, fire) <- newAddHandler+        network <- compile $ do+            ein  <- fromAddHandler ah+            eout <- f ein+            reactimate $ pure () <$ eout+        performSufficientGC+        actuate network+        pure (network, fire)++    run network fire = forM xs $ \i -> do+        fire i+        performSufficientGC+        System.yield+        Memory.evaluate =<< getSize network++-- | Test whether the network size stays bounded.+testBoundedNetworkSize+    :: String+    -> (Event Int -> MomentIO (Event ignore))+    -> TestTree+testBoundedNetworkSize name f = testProperty name $+    Q.once $ Q.monadicIO $ do+        sizes <- liftIO $ runNetworkSizes f [1..n]+        Q.monitor+            $ Q.counterexample "network size grows"+            . Q.counterexample ("network sizes: " <> show sizes)+        Q.assert $ isBounded sizes+  where+    n = 20 :: Int+    isBounded sizes = sizes !! 3 >= sizes !! (n-1)++performSufficientGC :: IO ()+performSufficientGC = System.performMinorGC
+ test/Reactive/Banana/Test/Low/Gen.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NamedFieldPuns #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Generation of intereseting example graphs.+module Reactive.Banana.Test.Low.Gen+    (+    -- * Simple graph types for testing+      TestGraph (..)+    , DeltaGraph (..)+    , Vertex++    -- * Example graphs+    , mkLinearChain+    , mkSquare+    +    -- * Generators+    , genTestGraph+    , genLinearChain+    , genSquare+    , genSquareSide+    , shuffleEdges+    ) where++import Test.QuickCheck+    ( Gen )+import qualified Test.QuickCheck as Q++{-----------------------------------------------------------------------------+    Graphs for testing+------------------------------------------------------------------------------}+type Vertex = Int++data DeltaGraph+    = InsertEdge Vertex Vertex+    deriving (Eq, Show)++data TestGraph = TestGraph+    { vertices :: [Vertex]+    , edges :: [DeltaGraph]+    } deriving (Eq, Show)++{-----------------------------------------------------------------------------+    Interesting example graphs+------------------------------------------------------------------------------}+-- | A linear chain   1 -> 2 -> 3 -> … -> n .+mkLinearChain :: Int -> TestGraph+mkLinearChain n = TestGraph{vertices,edges}+  where+    vertices = [1..n]+    edges = zipWith InsertEdge vertices (drop 1 vertices)++-- | A cartesian product of linear chains+mkSquare :: Int -> TestGraph+mkSquare n = TestGraph{vertices,edges}+  where+    toInt (x,y) = (x-1) + n*(y-1) + 1+    vertices = [ toInt (x,y) | y <- [1..n], x <- [1..n]]+    edges =+        [ InsertEdge (toInt (x,y)) (toInt (x+1,y))+        | y <- [1..n]+        , x <- [1..n-1]+        ]+        ++ +        [ InsertEdge (toInt (x,y)) (toInt (x,y+1))+        | y <- [1..n-1]+        , x <- [1..n]+        ]++{-----------------------------------------------------------------------------+    Generating various graphs+------------------------------------------------------------------------------}+-- | Interesting generator for 'TestGraph'.+genTestGraph :: Gen TestGraph+genTestGraph = shuffleEdges =<< Q.frequency+    [ (1, genLinearChain)+    , (1, genSquare)+    ]++shuffleEdges :: TestGraph -> Gen TestGraph+shuffleEdges g@TestGraph{edges} = (\e -> g{edges = e})<$> Q.shuffle edges++genLinearChain :: Gen TestGraph+genLinearChain = Q.sized $ pure . mkLinearChain++genSquare :: Gen TestGraph+genSquare = mkSquare <$> genSquareSide++genSquareSide :: Gen Int+genSquareSide = Q.sized $ \n -> Q.chooseInt (2,floorSqrt (2*n) + 2)++floorSqrt :: Int -> Int+floorSqrt = floor . sqrt . fromIntegral
+ test/Reactive/Banana/Test/Low/Graph.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NamedFieldPuns #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Property tests for 'Graph'.+module Reactive.Banana.Test.Low.Graph+    ( tests+    , mkGraph+    ) where++import Reactive.Banana.Prim.Low.Graph +    ( Graph )+import Reactive.Banana.Test.Low.Gen+    ( DeltaGraph (..), TestGraph (..), Vertex )+import Test.QuickCheck+    ( Gen, Property, (===), (=/=) )+import Test.Tasty+    ( testGroup, TestTree )+import Test.Tasty.QuickCheck+    ( testProperty )++import qualified Data.List as List+import qualified Test.QuickCheck as Q+import qualified Reactive.Banana.Test.Low.Gen as Q++import qualified Reactive.Banana.Prim.Low.Graph as Graph++tests :: TestTree+tests = testGroup "Graph"+    [ testGroup "walkSuccessors"+        [ testProperty "Predecessors have lower levels" prop_levelsInvariant+        , testProperty "succeeds on a square" prop_walkSquare+        ]+    ]++{-----------------------------------------------------------------------------+    Properties+------------------------------------------------------------------------------}+prop_levelsInvariant :: Property+prop_levelsInvariant = Q.forAll Q.genTestGraph $ \g0 ->+    let g = mkGraph g0+        level x = Graph.getLevel g x+    in+        Q.conjoin [ level x < level y | InsertEdge x y <- edges g0 ]++-- | Run 'walkSuccessors' on a square (with edges inserted randomly).+walkSquare :: Int -> Gen [Vertex]+walkSquare n = do+    g <- mkGraph <$> Q.shuffleEdges (Q.mkSquare n)+    Graph.walkSuccessors [1] (const step) g+  where+    step = Q.frequency [(10,pure Graph.Next), (1,pure Graph.Stop)]++prop_walkSquare :: Property+prop_walkSquare =+    Q.forAll Q.genSquareSide+    $ \n -> Q.cover 10 (n >= 10) "large square"+    $ Q.forAll (walkSquare n)+    $ \walk ->+    let correctOrder (x,y) =+            Q.counterexample (show y <> " precedes " <> show x)+                $ not $ (fromInt n y) `before` (fromInt n x)++        checkOrder = Q.conjoin $ replicate 10 $ do+            m <- Q.chooseInt (1, length walk - 1)+            pure+                $ Q.conjoin+                $ map correctOrder+                $ pairsFromPivot m walk++    in  Q.counterexample ("Walk result: " <> show walk)+        $ length walk >= 1+  where+    fromInt :: Int -> Vertex -> (Int, Int)+    fromInt n x = ((x-1) `mod` n, (x-1) `div` n)++    (x1,y1) `before` (x2,y2) = x1 <= x2 && y1 <= y2++pairsFromPivot :: Int -> [a] -> [(a,a)]+pairsFromPivot n [] = []+pairsFromPivot n xs = [(a,b) | a <- as] ++ [(b,c) | c <- cs]+  where+    (as, b:cs) = splitAt m xs+    m = max (length xs - 1) $ min 0 $ n++{-----------------------------------------------------------------------------+    Test graphs+------------------------------------------------------------------------------}+-- | Generate a 'Graph' from a 'TestGraph'.+mkGraph :: TestGraph -> Graph Vertex ()+mkGraph TestGraph{edges} = List.foldl' insertEdge Graph.empty edges+  where+    insertEdge g (InsertEdge x y) = Graph.insertEdge (x,y) () g
+ test/Reactive/Banana/Test/Low/GraphGC.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Property tests for 'GraphGC'.+module Reactive.Banana.Test.Low.GraphGC+    ( tests+    ) where++import Control.Monad+    ( when )+import Control.Monad.IO.Class+    ( liftIO )+import Data.Map.Strict+    ( Map )+import Data.Unique.Really+    ( Unique )+import Reactive.Banana.Prim.Low.Graph +    ( Graph )+import Reactive.Banana.Prim.Low.GraphGC+    ( GraphGC )+import Reactive.Banana.Test.Low.Gen+    ( DeltaGraph (..), TestGraph (..), Vertex )+import Test.QuickCheck+    ( Gen, Property, (===), (=/=) )+import Test.Tasty+    ( testGroup, TestTree )+import Test.Tasty.QuickCheck+    ( testProperty )++import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Control.DeepSeq as Memory+import qualified Control.Exception as Memory+import qualified System.Mem as System+import qualified Control.Concurrent as System++import qualified Test.QuickCheck as Q+import qualified Test.QuickCheck.Monadic as Q+import qualified Reactive.Banana.Test.Low.Graph as Q+import qualified Reactive.Banana.Test.Low.Gen as Q++import qualified Reactive.Banana.Prim.Low.Graph as Graph+import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC+import qualified Reactive.Banana.Prim.Low.Ref as Ref+++tests :: TestTree+tests = testGroup "GraphGC"+    [ testGroup "Garbage collection (GC)"+        [ testProperty "retains the reachable vertices" prop_performGC+        , testProperty "not doing GC retains all vertices" prop_notPerformGC+        ]+    ]++{-----------------------------------------------------------------------------+    Properties+------------------------------------------------------------------------------}+prop_performGC :: Property+prop_performGC =+    Q.forAll Q.genTestGraph+    $ \g0 -> Q.forAll (genGarbageCollectionRoots g0)+    $ \roots ->+    let g = Q.mkGraph g0+        expected = Graph.collectGarbage roots g+    in  Q.cover 10 (Graph.size g == Graph.size expected)+            "no   vertices unreachable"+        $ Q.cover 75 (Graph.size g > Graph.size expected)+            "some vertices unreachable"+        $ Q.cover 15 (Graph.size g > 2*Graph.size expected)+            "many vertices unreachable"+        $ Q.monadicIO $ liftIO $ do+            (actual, vertices) <- mkGraphGC g0+            let rootRefs = map (vertices Map.!) roots+            Memory.evaluate $ Memory.rnf rootRefs++            System.performMajorGC+            GraphGC.removeGarbage actual+            reachables <- traverse Ref.read =<<+                GraphGC.listReachableVertices actual++            -- keep rootsRef reachable until this point+            rootsFromRef <- traverse Ref.read rootRefs++            pure $+                ( roots === rootsFromRef )+                Q..&&.+                ( Set.fromList (Graph.listConnectedVertices expected)+                    === Set.fromList reachables+                )++prop_notPerformGC :: Property+prop_notPerformGC =+    Q.forAll Q.genSquareSide+    $ \n -> Q.monadicIO $ liftIO $ do+        -- Trigger a garbage collection now so that it is+        -- highly unlikely to happen in the subsequent lines+        System.performMinorGC++        let g = Q.mkLinearChain n++        (actual, _) <- mkGraphGC g+        GraphGC.removeGarbage actual+        reachables <- traverse Ref.read =<<+            GraphGC.listReachableVertices actual++        pure $+            Set.fromList reachables === Set.fromList [1..n]++{-----------------------------------------------------------------------------+    Test graphs+------------------------------------------------------------------------------}+-- | Generate a 'GraphGC' from a 'TestGraph'.+mkGraphGC :: TestGraph -> IO (GraphGC Vertex, Map Vertex (Ref.Ref Vertex))+mkGraphGC TestGraph{vertices,edges} = do+    g <- GraphGC.new+    refMap <- Map.fromList . zip vertices <$> traverse Ref.new vertices+    let insertEdge (InsertEdge x y) = do+            GraphGC.insertEdge (refMap Map.! x, refMap Map.! y) g+    traverse insertEdge edges+    pure (g, refMap)++-- | Randomly generate a set of garbage collection roots.+genGarbageCollectionRoots :: TestGraph -> Gen [Vertex]+genGarbageCollectionRoots TestGraph{vertices} = Q.sized $ \n ->+    sequence . replicate (n `mod` 10) $ Q.elements vertices
+ test/Reactive/Banana/Test/Mid/Space.hs view
@@ -0,0 +1,122 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- | Exemplar tests for space usage and garbage collection.+module Reactive.Banana.Test.Mid.Space where++import Control.Monad+    ( foldM )+import Control.Monad.IO.Class+    ( liftIO )+import Test.Tasty+    ( testGroup, TestTree )+import Test.Tasty.QuickCheck+    ( testProperty )++import qualified Test.QuickCheck as Q+import qualified Test.QuickCheck.Monadic as Q++import qualified Control.Exception as Memory+import qualified Control.Concurrent as System+import qualified System.Mem as System++import Reactive.Banana.Prim.Mid+    ( Build, BuildIO, Network, Pulse, Latch )+import qualified Reactive.Banana.Prim.Mid as Prim++tests :: TestTree+tests = testGroup "Space usage, mid level"+    [ testGroup "Network size stays bounded"+        [ testBoundedNetworkSize "executeP accumL" executeAccum1+        , testBoundedNetworkSize "switchP executeP accumL" switchAccum1+        ]+    ]++{-----------------------------------------------------------------------------+    Tests+------------------------------------------------------------------------------}+executeAccum1 :: Pulse Int -> Build (Pulse (Pulse Int))+executeAccum1 p1 = do+    p2 <- Prim.mapP mkP p1+    Prim.executeP p2 ()+  where+    mkP :: Int -> () -> Build (Pulse Int)+    mkP i () = do+        piId <- Prim.mapP (const id) p1+        (_, pi) <- Prim.accumL i piId+        pure pi++switchAccum1 :: Pulse Int -> Build (Pulse Int)+switchAccum1 p1 = do+    p2 <- executeAccum1 p1+    Prim.switchP p1 p2++{-----------------------------------------------------------------------------+    Test harness+------------------------------------------------------------------------------}+-- | Compile an FRP network description into a state machine,+-- which also performs garbage collection after every step.+compileToStateMachine+    :: (Pulse a -> BuildIO (Pulse ignore))+    -> IO (Network, a -> Network -> IO Network)+compileToStateMachine f = do+    (step,network0) <- Prim.compile build =<< Prim.emptyNetwork+    pure (network0, doStep step)+  where+    build = do+        (p1, step) <- Prim.newInput+        p2 <- f p1+        p3 <- Prim.mapP pure p2 -- wrap into Future+        Prim.addHandler p3 (\_ -> pure ())+        pure step++    doStep step x network1 = do+        (outputs, network2) <- step x network1+        outputs         -- don't forget to execute outputs+        performSufficientGC+        System.yield    -- wait for finalizers to run+        pure network2++-- | Execute an FRP network with a sequence of inputs+-- with intermittend of garbage collection and record network sizes.+runNetworkSizes+    :: (Pulse a -> BuildIO (Pulse ignore))+    -> [a] -> IO [Int]+runNetworkSizes f xs = do+    (network0, step0) <- compileToStateMachine f+    let step1 x network1 = do+            network2 <- step0 x network1+            size <- Memory.evaluate =<< Prim.getSize network2+            pure (size, network2)+    fst <$> Prim.mapAccumM step1 network0 xs++-- | Test whether the network size stays bounded.+testBoundedNetworkSize+    :: String+    -> (Pulse Int -> Build (Pulse ignore))+    -> TestTree+testBoundedNetworkSize name f = testProperty name $+    Q.once $ Q.monadicIO $ do+        sizes <- liftIO $ runNetworkSizes f [1..n]+        Q.monitor+            $ Q.counterexample "network size grows"+            . Q.counterexample ("network sizes: " <> show sizes)+        Q.assert $ isBounded sizes+  where+    n = 20 :: Int+    isBounded sizes = sizes !! 3 >= sizes !! (n-1)++performSufficientGC :: IO ()+performSufficientGC = System.performMinorGC++{-----------------------------------------------------------------------------+    Debugging+------------------------------------------------------------------------------}+-- | Print network after a given sequence of inputs+printNetwork+    :: (Pulse a -> BuildIO (Pulse ignore))+    -> [a] -> IO String+printNetwork f xs = do+    (network0, step) <- compileToStateMachine f+    network1 <- foldM (flip step) network0 xs+    Prim.printDot network1
+ test/reactive-banana-tests.hs view
@@ -0,0 +1,27 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Main where++import Test.Tasty+    ( defaultMain, testGroup )++import qualified Reactive.Banana.Test.Low.Graph+import qualified Reactive.Banana.Test.Low.GraphGC+import qualified Reactive.Banana.Test.Mid.Space+import qualified Reactive.Banana.Test.High.Combinators+import qualified Reactive.Banana.Test.High.Space++main = defaultMain $ testGroup "reactive-banana"+    [ testGroup "Low-level"+        [ Reactive.Banana.Test.Low.Graph.tests+        , Reactive.Banana.Test.Low.GraphGC.tests+        ]+    , testGroup "Mid-level"+        [ Reactive.Banana.Test.Mid.Space.tests+        ]+    , testGroup "High-level"+        [ Reactive.Banana.Test.High.Combinators.tests+        , Reactive.Banana.Test.High.Space.tests+        ]+    ]
+ test/space.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BangPatterns #-}+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Main where++import Control.Monad+  ( foldM, void )++import qualified Reactive.Banana.Test.Mid.Space as Mid+import qualified Reactive.Banana.Test.High.Space as High++main :: IO ()+main = do+    say "Running..."+    -- void $ High.runNetworkSizes High.executeAccumE1 [1..20000]+    -- void $ High.runNetworkSizes High.switchAccumE1 [1..10000]+    -- void $ High.runNetworkSizes High.observeAccumE1 [1..10000]+    -- void $ runMidNetwork Mid.executeAccum1 [1..50000]+    void $ runMidNetwork Mid.switchAccum1 [1..20000]+    say "Done"++say :: String -> IO ()+say = putStrLn++{-----------------------------------------------------------------------------+    Test harness+------------------------------------------------------------------------------}+runMidNetwork f xs = do+    (network0, step) <- Mid.compileToStateMachine f+    void $ runStrict step xs network0++runStrict :: Monad m => (a -> s -> m s) -> [a] -> s -> m s+runStrict f [] !s = pure s+runStrict f (x:xs) !s = runStrict f xs =<< f x s