packages feed

reactive-banana 0.8.1.2 → 1.3.2.0

raw patch · 61 files changed

Files

CHANGELOG.md view
@@ -1,6 +1,141 @@ 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.@@ -20,7 +155,7 @@  **version 0.8.0.4** -* Just a reupload. The previous archive was broken.+* Just a re-upload. The previous archive was broken.  **version 0.8.0.3** @@ -71,7 +206,7 @@ * 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 singaturs: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type.+* Change type signatures: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type.  **version 0.4.3.1**
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
@@ -70,7 +70,10 @@     counterDown <- fromAddHandler (addHandler eminus)     epause      <- fromAddHandler (addHandler espause) -    let ecount = accumE 0 $ ((+1) <$ counterUp) `union` (subtract 1 <$ counterDown)+    ecount <- accumE 0 $ unions+        [ (+1)       <$ counterUp+        , subtract 1 <$ counterDown+        ]      reactimate $ fmap print ecount     reactimate $ fmap pause epause
doc/examples/Octave.hs view
@@ -1,17 +1,22 @@ {-----------------------------------------------------------------------------     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 Data.Char     (toUpper) import Control.Monad (forever)-import System.IO (BufferMode(..), hSetEcho, hSetBuffering, stdin)+import System.IO     (BufferMode(..), hSetEcho, hSetBuffering, stdin)+ import Reactive.Banana-import Reactive.Banana.Prim (addHandler) import Reactive.Banana.Frameworks  @@ -40,7 +45,7 @@     show (Note o p) = show p ++ show o  -- Filter and transform events at the same time.-filterMapJust :: (a -> Maybe b) -> Event t a -> Event t b+filterMapJust :: (a -> Maybe b) -> Event a -> Event b filterMapJust f = filterJust . fmap f  -- Change the original octave by adding a number of octaves, taking@@ -55,16 +60,20 @@     '-' -> Just (-1)     _ -> Nothing -makeNetworkDescription :: Frameworks t => AddHandler Char -> Moment t ()+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-        eOctaveChange = filterMapJust getOctaveChange eKey-        bOctave = accumB 3 (changeOctave <$> eOctaveChange)-        ePitch = filterMapJust (`lookup` charPitches) eKey-        bPitch = stepper PC ePitch         bNote = Note <$> bOctave <*> bPitch         foo = Note 0 PA+     eNoteChanged <- changes bNote     reactimate' $ fmap (\n -> putStrLn ("Now playing " ++ show n))                  <$> eNoteChanged
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 @@ -79,10 +86,9 @@ data Win = Double | Triple  --- 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 <- liftIO $ newStdGen @@ -90,20 +96,19 @@     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@@ -111,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@@ -157,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,5 +1,5 @@ Name:                reactive-banana-Version:             0.8.1.2+Version:             1.3.2.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).@@ -9,18 +9,13 @@     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 library features an efficient, push-driven implementation+    /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.-    However, the inner loop still has a rather large constant factor overhead.-    Moreover, there is currently /no/ garbage collection for events that are-    created dynamically with @Reactive.Banana.Switch@.+    .+    /API guide./+    Start with the "Reactive.Banana" module.  Homepage:            http://wiki.haskell.org/Reactive-banana License:             BSD3@@ -28,82 +23,121 @@ Author:              Heinrich Apfelmus Maintainer:          Heinrich Apfelmus <apfelmus quantentunnel de> 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:     CHANGELOG.md,-                        doc/examples/*.hs,-                        src/Reactive/Banana/Test.hs,-                        src/Reactive/Banana/Test/Plumbing.hs+                        doc/examples/*.hs+extra-doc-files:        doc/*.png  Source-repository head     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.5 && < 0.6,-                        transformers >= 0.2 && < 0.5,-                        vault == 0.3.* -    extensions:         EmptyDataDecls,-                        BangPatterns--    build-depends:      unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.3,-                        psqueues >= 0.2 && < 0.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.Model,-                        Reactive.Banana.Prim,-                        Reactive.Banana.Prim.Cached,-                        Reactive.Banana.Switch-    +                        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.Combinators,-                        Reactive.Banana.Internal.Phantom,-                        Reactive.Banana.Prim.Combinators,-                        Reactive.Banana.Prim.Compile,-                        Reactive.Banana.Prim.Dated,-                        Reactive.Banana.Prim.Dependencies,-                        Reactive.Banana.Prim.Evaluation,-                        Reactive.Banana.Prim.IO,-                        Reactive.Banana.Prim.Order,-                        Reactive.Banana.Prim.Plumbing,-                        Reactive.Banana.Prim.Test,-                        Reactive.Banana.Prim.Types,+                        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 -Test-Suite tests+    ghc-options: -Wall -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-fields -Werror=partial-fields -Wno-name-shadowing++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, psqueues+    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
@@ -2,19 +2,18 @@     -- * 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 -type Map = Map.Map- {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}@@ -22,12 +21,12 @@ -- /event value/ and performs some computation. type Handler a = a -> IO () --- | A value of type @Addhandler a@ is a facility for registering+-- | 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 ()) }@@ -40,12 +39,12 @@  -- | Map the event value with an 'IO' action. mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b-mapIO f e = AddHandler $ \h -> register e $ \x -> f x >>= h +mapIO f e = AddHandler $ \h -> register e (f >=> h)  -- | Filter event values that don't return 'True'. filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a filterIO f e = AddHandler $ \h ->-    register e $ \x -> f x >>= \b -> if b then h x else return ()+    register e $ \x -> f x >>= \b -> when b $ h x  {-----------------------------------------------------------------------------     Construction@@ -68,7 +67,29 @@             atomicModifyIORef_ handlers $ Map.insert key handler             return $ atomicModifyIORef_ handlers $ Map.delete key         runHandlers a =-            mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers+            runAll a =<< readIORef handlers     return (AddHandler register, runHandlers) +atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())++-- | A callback is a @a -> IO ()@ function. We define this newtype to provide+-- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which+-- allow us to write the efficient 'runAll' function.+newtype Callback a = Callback { invoke :: a -> IO () }++instance Semigroup (Callback a) where+    Callback f <> Callback g = Callback $ \a -> f a >> g a++instance Monoid (Callback a) where+    mempty = Callback $ \_ -> return ()++-- This function can also be seen as+--+--   runAll a fs = mapM_ ($ a) fs+--+-- The reason we write this using 'foldMap' and 'Callback' is to produce code+-- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237+-- for more info.+runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO ()+runAll a fs = invoke (foldMap Callback fs) a
+ 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.Types-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,315 +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,+    unions, accumB, mapAccum,+    -- ** Merging events+    merge, mergeWith     ) where  import Control.Applicative-import Control.Monad-import Data.Maybe          (isJust, catMaybes)-import Data.Monoid         (Monoid(..))+import Data.Semigroup+import Data.These (These(..)) -import qualified Reactive.Banana.Internal.Combinators as Prim+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  {-----------------------------------------------------------------------------     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)+-- >     = 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 --- 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+{-$recursion --- | Apply a time-varying function to a stream of events.--- Think of it as--- --- > apply bf ex = [(time, bf time x) | (time, x) <- ex]------ This function is generally used in its infix variant '<@>'.-apply    :: Behavior t (a -> b) -> Event t a -> Event t b-apply bf ex = E $ Prim.applyE (Prim.mapB map $ unB bf) (unE ex)+/Recursion/ is a very important technique in FRP that is not apparent+from the type signatures. -{-$classes+Here is a prototypical example. It shows how the 'accumE' can be expressed+in terms of the 'stepper' and 'apply' functions by using recursion: -/Further combinators that Haddock can't document properly./+> 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 ------------------------------------------------------------------------------}-{---Unfortunately, we can't make a  Num  instance because that would-require  Eq  and  Show .--instance Num a => Num (Behavior t a) where-    (+) = liftA2 (+)-    (-) = liftA2 (-)-    (*) = liftA2 (*)-    negate = fmap negate-    abs    = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--}-infixl 4 <@>, <@+infixl 4 <@>, <@, @>  -- | Infix synonym for the 'apply' combinator. Similar to '<*>'.--- +-- -- > infixl 4 <@>-(<@>) :: Behavior t (a -> b) -> Event t a -> Event t b+(<@>) :: Behavior (a -> b) -> Event a -> Event b (<@>) = apply  -- | Tag all event occurrences with a time-varying value. Similar to '<*'. -- -- > infixl 4 <@-(<@)  :: Behavior t b -> Event t a -> Event t b-f <@ g = (const <$> f) <@> g +(<@)  :: 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)+-- > 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 --- | Keep only the last occurrence when simultaneous occurrences happen.-calm :: Event t a -> Event t a-calm = fmap last . collect  -- $Accumulation. -- 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)-+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,130 +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-    (<@>), (<@),-    ) 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)---- | Infix synonym for the 'apply' combinator. Similar to '<*>'.-(<@>) :: Behavior t (a -> b) -> Event t a -> Event t b-(<@>) = apply---- | Tag all event occurrences with a time-varying value. Similar to '<*'.-(<@)  :: Behavior t a -> Event t b -> Event t a-f <@ g = (const <$> f) <@> g --
src/Reactive/Banana/Frameworks.hs view
@@ -5,31 +5,36 @@  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,++    -- * Building event networks with input/output+    -- ** Core functions+    compile, MomentIO,     module Control.Event.Handler,     fromAddHandler, fromChanges, fromPoll,-    reactimate, Future, reactimate', initial, changes, imposeChanges,-    FrameworksMoment(..), execute, liftIOLater,+    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-    newEvent,-    -    -- * Internal-    interpretFrameworks, showNetwork,+    EventNetwork, actuate, pause, getSize,+     ) where  import           Control.Event.Handler@@ -37,8 +42,7 @@ import           Control.Monad.IO.Class import           Data.IORef import           Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.Combinators as Prim-import           Reactive.Banana.Internal.Phantom+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  @@ -58,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@@ -91,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 >@@ -112,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', @@ -137,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@@ -145,16 +149,16 @@ Your event-based framework will have to handle this situation.  -}-reactimate :: Frameworks t => Event t (IO ()) -> Moment t ()-reactimate = M . Prim.addReactimate . Prim.mapE (return . 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' :: Frameworks t => Event t (Future (IO ())) -> Moment t ()-reactimate' = M . Prim.addReactimate . Prim.mapE (unF . fmap sequence_ . sequence) . unE+reactimate' :: Event (Future (IO ())) -> MomentIO ()+reactimate' = MIO . Prim.addReactimate . Prim.mapE unF . unE   -- | Input,@@ -163,8 +167,8 @@ -- 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.@@ -174,78 +178,116 @@ -- -- 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---- | Output,--- observe the initial value contained in a 'Behavior'.-initial :: Behavior t a -> Moment t a-initial = M . Prim.initialB . unB+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: ----- Note: The values of the event will not become available--- until event processing is complete.+-- > 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 :: Frameworks t => Behavior t a -> Moment t (Event t (Future a))-changes = return . fmap F . singletonsE . Prim.changesB . unB+changes :: Behavior a -> MomentIO (Event (Future a))+changes = return . E . Prim.mapE F . Prim.changesB . unB +{- $changes++Note: If you need a variant of the 'changes' function that does /not/+have the additional 'Future' type, then the following code snippet+may be useful:++> plainChanges :: Behavior a -> MomentIO (Event a)+> plainChanges b = do+>     (e, handle) <- newEvent+>     eb <- changes b+>     reactimate' $ (fmap handle) <$> eb+>     return e++However, this approach is not recommended, because the result 'Event'+will occur /slightly/ later than the event returned by 'changes'.+In fact, there is no guarantee whatsoever about what /slightly/ means+in this context. Still, it is useful in some cases.++-}+ -- | Impose a different sampling event on a 'Behavior'. ----- The 'Behavior' will vary continuously as before, but the event returned+-- 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 :: Frameworks t => Behavior t a -> Event t () -> Behavior t a+imposeChanges :: Behavior a -> Event () -> Behavior a imposeChanges b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e)) --- | Dummy type needed to simulate impredicative polymorphism.-newtype FrameworksMoment a-    = FrameworksMoment-    { runFrameworksMoment :: forall t. Frameworks t => Moment t a }+{- | Dynamically add input and output to an existing event network. -unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a-unFM = runFrameworksMoment --- | Dynamically add input and output to an existing event network.------ 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+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.@@ -253,17 +295,14 @@ -- | 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@@ -293,70 +332,92 @@ pause :: EventNetwork -> IO () pause   = Prim.pause . unEN --- | A multiline description of the current 'Latch'es and 'Pulse's in--- the 'EventNetwork'.+-- | 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'. ----- Incidentally, evaluation the returned string to normal--- form will also force the 'EventNetwork' to some kind of normal form.--- This may be useful for benchmarking purposes.-showNetwork :: EventNetwork -> IO String-showNetwork = Prim.showNetwork . unEN+-- 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 :: (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, Handler a)-newEvent = do-    (addHandler, fire) <- liftIO $ newAddHandler-    e <- fromAddHandler addHandler-    return (e,fire)
− src/Reactive/Banana/Internal/Combinators.hs 
@@ -1,210 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-}-module Reactive.Banana.Internal.Combinators where--import           Control.Concurrent.MVar-import           Control.Event.Handler-import           Control.Monad-import           Control.Monad.Fix-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class           (lift)-import           Control.Monad.Trans.Reader-import           Data.Functor-import           Data.Functor.Identity-import           Data.IORef-import qualified Data.Vault.Lazy             as Lazy-import qualified Reactive.Banana.Prim        as Prim-import qualified Reactive.Banana.Prim.Cached as Prim-import           Reactive.Banana.Prim.Cached         hiding (runCached)--type Build   = Prim.Build-type Latch   = Prim.Latch-type Pulse   = Prim.Pulse-type Future  = Prim.Future--{------------------------------------------------------------------------------    Types-------------------------------------------------------------------------------}-type Behavior a = Cached Moment' (Latch a, Pulse ())-type Event a    = Cached Moment' (Pulse a)--type MomentT m  = ReaderT EventNetwork (Prim.BuildT m)-type Moment     = MomentT IO-type Moment'    = MomentT Identity--instance (Monad m, MonadFix m, HasCache m)-    => HasCache (ReaderT EventNetwork m) where-        retrieve key = lift $ retrieve key-        write key a  = lift $ write key a--liftBuild :: Monad m => Build a -> MomentT m a-liftBuild = lift . Prim.liftBuild--runCached :: Monad m => Cached Moment' a -> MomentT m a-runCached = mapReaderT Prim.liftBuild . Prim.runCached--{------------------------------------------------------------------------------    Interpretation-------------------------------------------------------------------------------}-interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined-    where-    g pulse = runCached =<< f (Prim.fromPure pulse)-    -- Ignore any  addHandler  inside the  Moment--{------------------------------------------------------------------------------    IO-------------------------------------------------------------------------------}--- | Data type representing an event network.-data EventNetwork = EventNetwork-    { runStep :: Prim.Step -> IO ()-    , actuate :: IO ()-    , pause   :: IO ()-    , showNetwork :: IO String-    }---- | Compile to an event network.-compile :: Moment () -> IO EventNetwork-compile setup = do-    actuated <- newIORef False                   -- flag to set running status-    s        <- newEmptyMVar                     -- setup callback machinery-    let-        whenFlag flag action = readIORef flag >>= \b -> when b action-        runStep f            = whenFlag actuated $ do-            s1 <- takeMVar s                    -- read and take lock-            -- pollValues <- sequence polls     -- poll mutable data-            (output, s2) <- f s1                -- calculate new state-            putMVar s s2                        -- write state-            output                              -- run IO actions afterwards--        eventNetwork = EventNetwork-            { runStep = runStep-            , actuate = writeIORef actuated True-            , pause   = writeIORef actuated False-            , showNetwork = show <$> readMVar s-            }--    (output, s0) <-                             -- compile initial graph-        Prim.compile (runReaderT setup eventNetwork) Prim.emptyNetwork-    putMVar s s0                                -- set initial state-        -    return $ eventNetwork--fromAddHandler :: AddHandler a -> Moment (Event a)-fromAddHandler addHandler = do-    key       <- liftIO $ Lazy.newKey-    (p, fire) <- liftBuild $ Prim.newInput key-    network   <- ask-    liftIO $ register addHandler $ runStep network . fire-    return $ Prim.fromPure p--addReactimate :: Event (Future (IO ())) -> Moment ()-addReactimate e = do-    p <- runCached e-    liftBuild $ Prim.addHandler p id--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-    return $ 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       = don'tCache  $ liftBuild $ Prim.neverP-unionWith f = liftCached2 $ (liftBuild .) . Prim.unionWithP f-filterJust  = liftCached1 $ liftBuild . Prim.filterJustP-accumE x    = liftCached1 $ liftBuild . fmap snd . Prim.accumL x-mapE f      = liftCached1 $ liftBuild . Prim.mapP f-applyE      = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px--changesB    = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px---- FIXME: To allow more recursion, create the latch first and--- build the pulse later.-stepperB a  = \c1 -> cache $ do-    p0 <- runCached c1-    liftBuild $ do-        p1    <- Prim.mapP const p0-        p2    <- Prim.mapP (const ()) p1-        (l,_) <- Prim.accumL a p1-        return (l,p2)--pureB a = stepperB a never-applyB  = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do-    p3 <- Prim.unionWithP const p1 p2-    let l3 = Prim.applyL l1 l2-    return (l3,p3)-mapB f  = applyB (pureB f)--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-initialB :: Behavior a -> Moment a-initialB b = do-    ~(l,_) <- runCached b-    liftBuild $ Prim.readLatch l--trimE :: Event a -> Moment (Moment (Event a))-trimE e = do-    p <- runCached e                   -- add pulse to network-    -- NOTE: if the pulse is not connected to an input node,-    -- it will be garbage collected right away.-    -- TODO: Do we need to check for this?-    return $ return $ fromPure p       -- remember it henceforth--trimB :: Behavior a -> Moment (Moment (Behavior a))-trimB b = do-    ~(l,p) <- runCached b               -- add behavior to network-    return $ return $ fromPure (l,p)    -- remember it henceforth--executeP :: Monad m => Pulse (Moment a) -> MomentT m (Pulse a)-executeP p1 = do-    p2 <- liftBuild $ Prim.mapP runReaderT p1-    r <- ask-    liftBuild $ Prim.executeP p2 r--observeE :: Event (Moment a) -> Event a -observeE = liftCached1 $ executeP--executeE :: Event (Moment a) -> Moment (Event a)-executeE e = do-    p      <- runCached e-    result <- executeP p-    return $ fromPure result--switchE :: Event (Moment (Event a)) -> Event a-switchE = liftCached1 $ \p1 -> do-    p2 <- liftBuild $ Prim.mapP (runCached =<<) p1-    p3 <- executeP p2-    liftBuild $ Prim.switchP p3--switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a-switchB = liftCached2 $ \(l0,p0) p1 -> do-    p2 <- liftBuild $ Prim.mapP (runCached =<<) p1-    p3 <- executeP p2-    -    liftBuild $ do-        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.unionWithP (\_ _ -> ())
− 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/Model.hs view
@@ -1,152 +1,184 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}+{-# 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.hs 
@@ -1,42 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Prim (-    -- * Synopsis-    -- | This is an internal module, useful if you want to-    -- implemented your own FRP library.-    -- If you just want to use FRP in your project,-    -- have a look at "Reactive.Banana" instead.-    -    -- * Evaluation-    Step, Network, emptyNetwork,-    -    -- * Build FRP networks-    Build, liftIOLater, BuildIO, BuildT, liftBuild, compile,-    module Control.Monad.IO.Class,-    -    -- * Testing-    interpret, mapAccumM, mapAccumM_, runSpaceProfile,-    -    -- * IO-    newInput, addHandler, readLatch,-    -    -- * Pulse-    Pulse,-    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, unionWithP,-    -    -- * Latch-    Latch,-    pureL, mapL, applyL, accumL, applyP,-    -    -- * Dynamic event switching-    switchL, executeP, switchP-  ) where---import Control.Monad.IO.Class-import Reactive.Banana.Prim.Combinators-import Reactive.Banana.Prim.Compile-import Reactive.Banana.Prim.IO-import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, liftIOLater)-import Reactive.Banana.Prim.Types
− src/Reactive/Banana/Prim/Cached.hs 
@@ -1,72 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Cached (-    -- | Utility for executing monadic actions once-    -- and then retrieving values from a cache.-    -- -    -- Very useful for observable sharing.-    HasCache(..),-    Cached, runCached, cache, fromPure, don'tCache,-    liftCached1, liftCached2,-    ) where--import           Control.Monad-import           Control.Monad.Fix-import           Data.Unique.Really-import qualified Data.Vault.Lazy    as Lazy (Key, newKey)-import           System.IO.Unsafe           (unsafePerformIO)--{------------------------------------------------------------------------------    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 lazy 'Vault' that can be used as a cache.------ The cache has to be lazy in the values in order to be useful for recursion.-class (Monad m, MonadFix m) => HasCache m where-    retrieve :: Lazy.Key a -> m (Maybe a)-    write    :: Lazy.Key a -> a -> m ()---- | An action whose result will be cached.--- Executing the action the first time in the monad will--- execute the side effects. From then on,--- only the generated value will be returned.-{-# NOINLINE cache #-}-cache :: HasCache m => m a -> Cached m a-cache m = unsafePerformIO $ do-    key <- Lazy.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.-fromPure :: HasCache m => a -> Cached m a-fromPure = Cached . return---- | Lift an action that is /not/ chached, for instance because it is idempotent.-don'tCache :: HasCache m => m a -> Cached m a-don'tCache = Cached--liftCached1 :: HasCache m => (a -> m b) -> Cached m a -> Cached m b-liftCached1 f ca = cache $ do-    a <- runCached ca-    f a--liftCached2 :: HasCache 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/Combinators.hs 
@@ -1,191 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Combinators where--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class--import Reactive.Banana.Prim.Dated (Box(..))-import Reactive.Banana.Prim.Plumbing-    ( neverP, newPulse, newLatch, cachedLatch-    , dependOn, changeParent-    , readPulseP, readLatchP, readLatchFutureP, liftBuildP, liftBuildIOP-    )-import Reactive.Banana.Prim.Types (Latch(..), Future, Pulse, Build, BuildIO)--import Debug.Trace--- debug s = trace s-debug s = id--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-mapP :: (a -> b) -> Pulse a -> Build (Pulse b)-mapP f p1 = do-    p2 <- newPulse "mapP" $ {-# SCC mapP #-} fmap f <$> readPulseP p1-    p2 `dependOn` p1-    return p2---- | Tag a 'Pulse' with future values of a 'Latch'.------ This is in contrast to 'applyP' which applies the current value--- of a 'Latch' to a pulse.-tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))-tagFuture x p1 = do-    p2 <- newPulse "tagFuture" $-        fmap . const <$> readLatchFutureP x <*> readPulseP p1-    p2 `dependOn` p1-    return p2--filterJustP :: Pulse (Maybe a) -> Build (Pulse a)-filterJustP p1 = do-    p2 <- newPulse "filterJustP" $ {-# SCC filterJustP #-} join <$> readPulseP p1-    p2 `dependOn` p1-    return p2--unsafeMapIOP :: (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 (Just x) = Just <$> liftIO (f x)-    eval Nothing  = return Nothing--unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)-unionWithP f px py = do-        p <- newPulse "unionWithP" $-            {-# SCC unionWithP #-} eval <$> readPulseP px <*> readPulseP py-        p `dependOn` px-        p `dependOn` py-        return p-    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---- 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 a = Latch { getValueL = return (pure a) }---- specialization of   mapL f = applyL (pureL f)-mapL :: (a -> b) -> Latch a -> Latch b-mapL f lx = cachedLatch $ {-# SCC mapL #-} fmap f <$> getValueL lx--applyL :: Latch (a -> b) -> Latch a -> Latch b-applyL lf lx = cachedLatch $-    {-# SCC applyL #-} (<*>) <$> getValueL lf <*> getValueL lx--accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)-accumL a p1 = do-    (updateOn, x) <- newLatch a-    p2 <- applyP (mapL (\x f -> f x) x) p1-    updateOn p2-    return (x,p2)---- specialization of accumL-stepperL :: a -> Pulse a -> Build (Latch a)-stepperL a p = do-    (updateOn, x) <- newLatch a-    updateOn p-    return x--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)-switchL l pl = mdo-    x <- stepperL l pl-    return $ Latch { getValueL = getValueL x >>= \(Box a) -> getValueL a }--executeP :: Pulse (b -> BuildIO a) -> b -> Build (Pulse a)-executeP p1 b = do-        p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1-        p2 `dependOn` p1-        return p2-    where-    eval (Just x) = Just <$> liftBuildIOP (x b)-    eval Nothing  = return Nothing--switchP :: Pulse (Pulse a) -> Build (Pulse a)-switchP pp = mdo-    never <- neverP-    lp    <- stepperL never pp-    let-        -- switch to a new parent-        switch = do-            mnew <- readPulseP pp-            case mnew of-                Nothing  -> return ()-                Just new -> liftBuildP $ p2 `changeParent` new-            return Nothing-        -- fetch value from old parent-        eval = readPulseP =<< readLatchP lp-    -    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())-    p1 `dependOn` pp-    p2 <- newPulse "switchP_out" eval-    return p2--{------------------------------------------------------------------------------    Notes-------------------------------------------------------------------------------}-{---* Note [PulseCreation]--We assume that we do not have to calculate a pulse occurrence-at the moment we create the pulse. Otherwise, we would have-to recalculate the dependencies *while* doing evaluation;-this is a recipe for desaster.--* Note [unsafePerformIO]--We're using @unsafePerformIO@ only to get @Key@ and @Unique@.-It's not great, but it works.--Unfortunately, using @IO@ as the base of the @Network@ monad-transformer doens't work because it doesn't support recursion-and @mfix@ very well.--We could use the @ST@ monad, but this would add a type parameter-to everything. A refactoring of this scope is too annoying for-my taste right now.--* Note [LatchRecursion]--...--* Note [LatchStrictness]--Any value that is stored in the graph over a longer-period of time must be stored in WHNF.--This implies that the values in a latch must be forced to WHNF-when storing them. That doesn't have to be immediately-since we are tying a knot, but it definitely has to be done-before  evaluateGraph  is done.--It also implies that reading a value from a latch must-be forced to WHNF before storing it again, so that we don't-carry around the old collection of latch values.-This is particularly relevant for `applyL`.--Conversely, since latches are the only way to store values over time,-this is enough to guarantee that there are no space leaks in this regard.---}--
− src/Reactive/Banana/Prim/Compile.hs 
@@ -1,83 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Prim.Compile where--import           Data.Functor-import           Data.IORef-import qualified Data.Vault.Lazy                  as Lazy-import           Reactive.Banana.Prim.Combinators-import           Reactive.Banana.Prim.IO-import           Reactive.Banana.Prim.Plumbing-import           Reactive.Banana.Prim.Types--{------------------------------------------------------------------------------   Compilation-------------------------------------------------------------------------------}--- | Change a 'Network' of pulses and latches by --- executing a 'BuildIO' action.-compile :: BuildIO a -> Network -> IO (a, Network)-compile = flip runBuildIO--{------------------------------------------------------------------------------    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-    key <- Lazy.newKey-    o   <- newIORef Nothing-    let network = do-            (pin, sin) <- liftBuild $ newInput key-            pmid       <- f pin-            pout       <- liftBuild $ mapP return pmid-            liftBuild $ addHandler pout (writeIORef o . Just)-            return sin-    -    -- compile initial network-    (sin, state) <- compile network emptyNetwork--    let go Nothing  s1 = return (Nothing,s1)-        go (Just a) s1 = do-            (reactimate,s2) <- sin a s1-            reactimate              -- write output-            ma <- readIORef o       -- read output-            writeIORef o Nothing-            return (ma,s2)-    -    mapAccumM go state xs         -- run several steps---- | Execute an FRP network with a sequence of inputs, but discard results.--- --- Mainly useful for testing whether there are space leaks. -runSpaceProfile :: (Pulse a -> BuildIO void) -> [a] -> IO ()-runSpaceProfile f xs = do-    key <- Lazy.newKey-    let g = do-        (p1, fire) <- liftBuild $ newInput key-        f p1-        return fire-    (fire,network) <- compile g emptyNetwork-    -    mapAccumM_ fire network xs---- | 'mapAccum' for a monad.-mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]-mapAccumM _ _  []     = return []-mapAccumM f s0 (x:xs) = do-    (b,s1) <- f x s0-    bs     <- mapAccumM f s1 xs-    return (b:bs)---- | Strict 'mapAccum' for a monad. Discards results.-mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()-mapAccumM_ _ _  []     = return ()-mapAccumM_ f s0 (x:xs) = do-    (_,s1) <- f x s0-    mapAccumM_ f s1 xs-
− src/Reactive/Banana/Prim/Dated.hs 
@@ -1,106 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Prim.Dated (-    -- | A cache with timestamps.-    -    -- * Time-    Time, ancient, beginning, next,-    -- * Cache-    Vault, Key, empty, newKey, findWithDefault,-    -- * Strictness-    Box(..),-    -- * Computations-    Dated, runDated, update', cache,-    -    ) where--import           Control.Applicative               hiding (empty)-import           Control.Monad.Trans.RWS-import           Data.Functor-import           Data.Monoid-import qualified Data.Vault.Strict       as Strict-import           Prelude                           hiding (lookup)--{------------------------------------------------------------------------------    Time monoid-------------------------------------------------------------------------------}-newtype Time = T Integer deriving (Eq, Ord, Show, Read)--ancient :: Time-ancient = T 0--beginning :: Time-beginning = T 1--next :: Time -> Time-next (T n) = T (n+1)--instance Monoid Time where-    mappend (T x) (T y) = T (max x y)-    mempty              = ancient--{------------------------------------------------------------------------------    Strictness-------------------------------------------------------------------------------}--- | A strict box of potentially lazy value.-data Box a = Box { unBox :: a }--instance Functor Box where-    fmap f (Box x) = Box (f x)--instance Applicative Box where-    pure x = Box x-    (Box f) <*> (Box x) = Box (f x)--{------------------------------------------------------------------------------    Cache data type-------------------------------------------------------------------------------}-newKey :: IO (Key a)-newKey = Strict.newKey--empty :: Vault-empty = Strict.empty--type Vault = Strict.Vault-type Key a = Strict.Key (Timed a)--{------------------------------------------------------------------------------    Cached computations-------------------------------------------------------------------------------}-type Dated   = RWS () Time Vault-data Timed a = Timed !(Box a) !Time--runDated :: Dated a -> Vault -> (a, Vault)-runDated m s1 = let (a,s2,_) = runRWS m () s1 in (a,s2)--findWithDefault :: a -> Key a -> Dated (Box a)-findWithDefault a key = do-    ma <- Strict.lookup key <$> get-    case ma of-        Nothing          -> return (Box a)-        Just (Timed a t) -> tell t >> return a---- | Update a value inside the cache.--- The value will be evaluated to WHNF when the cache is evaluated to WHNF.-update' :: Key a -> Time -> a -> Vault -> Vault-update' key t a = Strict.insert key (Timed (a `seq` Box a) t)--cache :: Key a -> Dated (Box a) -> Dated (Box a)--- cache key m = m--- Observation: If  a  is a function type, then forcing--- it will not necessarily remove all the function application things.-cache key m = do-    (aNew, timeNew) <- listen m-    let refresh = do-            modify $ Strict.insert key (Timed aNew timeNew)-            return aNew-    -    ma <- Strict.lookup key <$> get-    case ma of-        Just (Timed aOld timeOld)-            | timeOld >= timeNew -> do          -- cache is more recent -                                    tell timeOld-                                    return aOld-            | otherwise          -> refresh     -- cache is too old-        Nothing                  -> refresh
− src/Reactive/Banana/Prim/Dependencies.hs 
@@ -1,172 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-module Reactive.Banana.Prim.Dependencies (-    -- | Utilities for operating with dependency graphs.-    Deps, dOrder, empty, allChildren, children, parents,-    addChild, changeParent,-    -    Continue(..), maybeContinue, traverseDependencies,-    -    DepsQueue, emptyQ, insert, minView,-    ) where--import           Control.Monad.Trans.Writer-import qualified Data.HashMap.Strict        as Map-import qualified Data.HashSet               as Set-import           Data.Hashable-import qualified Data.IntPSQ                as Q--import           Reactive.Banana.Prim.Order-import qualified Reactive.Banana.Prim.Order as Order--type Map = Map.HashMap-type Set = Set.HashSet--{------------------------------------------------------------------------------    Dependency graph-------------------------------------------------------------------------------}--- | A dependency graph.-data Deps a = Deps-    { dChildren :: Map a [a]     -- children depend on their parents-    , dParents  :: Map a [a]-    , dOrder    :: Order a-    } deriving (Show)---- | Representation of the depencencies as an association list of nodes--- to children.-allChildren :: Deps a -> [(a, [a])]-allChildren = Map.toList . dChildren---- | Children of a node.-children deps x =-    {-# SCC children #-} maybe [] id . Map.lookup x $ dChildren deps---- | Parents of a node.-parents  deps x = maybe [] id . Map.lookup x $ dParents  deps---- | The empty dependency graph.-empty :: Hashable a => Deps a-empty = Deps-    { dChildren = Map.empty-    , dParents  = Map.empty-    , dOrder    = Order.flat-    }---- | Add a new dependency.-addChild :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-addChild parent child deps1@(Deps{..}) = deps2-    where-    deps2 = Deps-        { dChildren = Map.insertWith (++) parent [child] dChildren-        , dParents  = Map.insertWith (++) child [parent] dParents-        , dOrder    = ensureAbove child parent dOrder-        }-    when b f = if b then f else id---- | Change the parent of the first argument to be the second one.-changeParent :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-changeParent child parent deps1@(Deps{..}) = deps2-    where-    deps2 = Deps-        { dChildren = Map.insertWith (++) parent [child]-                    $ removeChild parentsOld dChildren-        , dParents  = Map.insert child [parent] dParents-        , dOrder    = recalculateParent child parent (parents deps2) dOrder-        }-    parentsOld   = parents deps1 child-    removeChild1 = Map.adjust (filter (/= child))-    removeChild  = concatenate . map removeChild1-    concatenate  = foldr (.) id--{------------------------------------------------------------------------------    Traversal-------------------------------------------------------------------------------}--- | Data type for signaling whether to continue a traversal or not.-data Continue = Children | Done-    deriving (Eq, Ord, Show, Read)---- | Convert a 'Maybe' value into a 'Continue' decision.-maybeContinue :: Maybe a -> Continue-maybeContinue Nothing  = Done-maybeContinue (Just _) = Children---- | Starting with a set of root nodes, peform a monadic action--- for each node. If the action returns 'Children', its children will also--- be traversed at some point.--- However, all nodes are traversed in dependency order:--- A child node is only traversed when all its parent nodes have been traversed.-traverseDependencies :: forall a m. (Eq a, Hashable a, Monad m)-    => (a -> m Continue) -> Deps a -> [a] -> m ()-traverseDependencies f deps roots = go $ insertList roots emptyQ-    where-    order = dOrder deps-    insertList xs q = foldr (\x -> insert (level x order) x) q xs--    go q1 = case minView q1 of-        Nothing      -> return ()-        Just (a, q2) -> do-            continue <- f a-            case continue of-                Done     -> go q2-                Children -> go $ insertList (children deps a) q2---- | Queue for traversing dependencies.------ The 'Int' is a key supply for the priority search queue.-data DepsQueue a = DQ !(Q.IntPSQ Level a) !(Set a) Int--emptyQ :: DepsQueue a-emptyQ = DQ Q.empty Set.empty 0--insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a-insert k a q@(DQ queue seen n) = {-# SCC insert #-}-    if a `Set.member` seen-        then q-        else DQ (Q.insert (n+1) k a queue) (Set.insert a seen) (n+1)--minView :: DepsQueue a -> Maybe (a, DepsQueue a)-minView (DQ queue seen n) = {-# SCC minView #-} case Q.minView queue of-    Nothing                -> Nothing-    Just (_, _, a, queue2) -> Just (a, DQ queue2 seen n)--{------------------------------------------------------------------------------    Small tests-------------------------------------------------------------------------------}-test1 = id-    . changeParent 'C' 'A'-    . addChild 'C' 'D'-    . addChild 'B' 'C'-    . addChild 'B' 'D'-    . addChild 'A' 'B'-    . addChild 'a' 'B'-    $ empty--{- test2 =-        a-       / \-      b   d   A-      |   |   |-      c   e   B-       \ / \ /-        f   g-         \ /-          h---}-test2 = id-    . addChild 'g' 'h' . addChild 'e' 'g'-    . addChild 'B' 'g' . addChild 'A' 'B'-    . addChild 'f' 'h'-    . addChild 'e' 'f' . addChild 'd' 'e' . addChild 'a' 'd'-    . addChild 'c' 'f' . addChild 'b' 'c' . addChild 'a' 'b'-    $ empty--test3 = changeParent 'A' 'f' $ test2--listChildren :: (Eq a, Hashable a) => Deps a -> a -> [a]-listChildren deps x = snd $ runWriter $ traverseDependencies f deps [x]-    where f x = tell [x] >> return Children-
− src/Reactive/Banana/Prim/Evaluation.hs 
@@ -1,75 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, BangPatterns #-}-module Reactive.Banana.Prim.Evaluation where--import qualified Control.Exception    as Strict (evaluate)-import           Data.Monoid-import           Data.List (foldl')--import qualified Reactive.Banana.Prim.Dated        as Dated-import qualified Reactive.Banana.Prim.Dependencies as Deps-import           Reactive.Banana.Prim.Order-import           Reactive.Banana.Prim.Plumbing-import           Reactive.Banana.Prim.Types--{------------------------------------------------------------------------------    Graph evaluation-------------------------------------------------------------------------------}--- | Evaluate all the pulses in the graph,--- Rebuild the graph as necessary and update the latch values.-step :: Inputs -> Step-step (pulse1, roots) state1 = {-# SCC step #-} mdo-    let graph1 = nGraph state1-        latch1 = nLatchValues state1-        time1  = nTime state1--    -- evaluate pulses while recalculating some latch values-    ((_, latchUpdates, output), state2)-            <- runBuildIO state1-            $  runEvalP pulse1-            $  evaluatePulses graph1 roots-    -    let-        -- updated graph dependencies-        graph2 = nGraph state2-        -- update latch values from accumulations-        latch2 = appEndo latchUpdates $ nLatchValues state2-        -- calculate output actions, possibly recalculating more latch values-        (actions, latch3) = Dated.runDated output latch2--    -- make sure that the latch values are in WHNF-    Strict.evaluate $ {-# SCC evaluate #-} latch3-    return (actions, Network-            { nGraph       = graph2-            , nLatchValues = latch3-            , nTime        = Dated.next time1-            })---type Result = (EvalL, [(Position, EvalO)])-type Q      = Deps.DepsQueue---- | Update all pulses in the graph, starting from a given set of nodes-evaluatePulses :: Graph -> [SomeNode] -> EvalP Result-evaluatePulses Graph { grDeps = deps } roots =-        go mempty [] $ insertList roots Deps.emptyQ-    where-    order = Deps.dOrder deps-    -    go :: EvalL -> [(Position,EvalO)] -> Q SomeNode -> EvalP Result-    go el eo !q1 = {-# SCC go #-} case Deps.minView q1 of-        Nothing      -> return (el, eo)-        Just (a, q2) -> case a of-            P p -> evaluateP p >>= \c -> case c of-                Deps.Children -> go el eo $ insertList (Deps.children deps a) q2-                Deps.Done     -> go el eo q2-            L l -> evaluateL l >>= \x -> go (el `mappend` x) eo      q2-            O o -> evaluateO o >>= \x -> go el ((positionO o, x):eo) q2--    insertList :: [SomeNode] -> Q SomeNode -> Q SomeNode-    insertList xs q = {-# SCC insertList #-}-        foldl' (\q node -> Deps.insert (level node order) node q) q xs--
+ 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/IO.hs 
@@ -1,51 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Prim.IO where--import           Data.Functor-import           Data.Unique.Really-import qualified Data.Vault.Strict  as Strict-import qualified Data.Vault.Lazy    as Lazy-import           System.IO.Unsafe             (unsafePerformIO)--import Reactive.Banana.Prim.Combinators  (mapP)-import Reactive.Banana.Prim.Dependencies (maybeContinue)-import Reactive.Banana.Prim.Evaluation   (step)-import Reactive.Banana.Prim.Plumbing-import Reactive.Banana.Prim.Types--debug s = id--{------------------------------------------------------------------------------    Primitives connecting to the outside world-------------------------------------------------------------------------------}--- | Create a new pulse in the network and a function to trigger it.------ Together with 'addHandler', this function can be used to operate with--- pulses as with standard callback-based events.-newInput :: Lazy.Key a -> Build (Pulse a, a -> Step)-newInput key = unsafePerformIO $ do-    uid <- newUnique-    let pulse = Pulse-            { evaluateP = maybeContinue <$> readPulseP pulse-            , getValueP = Lazy.lookup key-            , uidP      = uid-            , nameP     = "newInput"-            }-    return $ do-        always <- alwaysP-        let inputs a = (Lazy.insert key a Lazy.empty, [P pulse, P always])-        return (pulse, step . inputs)---- | 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/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/Prim/Order.hs 
@@ -1,90 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, BangPatterns, RecordWildCards #-}-module Reactive.Banana.Prim.Order (-    -- * Synopsis-    -- | Data structure that represents a partial ordering by levels.-    -    -- * Order-    Order, flat,-    ensureAbove, recalculateParent,-    Level, level,-    -    ) where--import Data.Functor-import qualified Data.HashMap.Strict as Map-import qualified Data.HashSet        as Set-import           Data.Hashable-import qualified Data.IntMap.Strict  as IntMap--type IntMap = IntMap.IntMap-type Map    = Map.HashMap-type Set    = Set.HashSet--{------------------------------------------------------------------------------    Order by levels-------------------------------------------------------------------------------}--- | Each element is assigned a /level/.--- Elements in lower levels come before elements in higher levels.--- There is no order on elements within the same level.-type Order a = Map a Level---- | FIXME: Level should be an 'Integer' to avoid overflow.------ FIXME: The algorithms in this module currently do not try to--- shrink the number or width of levels.-type Level   = Integer---- | The flat order where every element is at 'ground' level.-flat :: Order a-flat = Map.empty---- | Ground level.-ground :: Level-ground = 0---- | Look up the level of an element. Default level is 'ground'.-level :: (Eq a, Hashable a) => a -> Order a -> Level-level x = {-# SCC level #-} maybe ground id . Map.lookup x---- | Make sure that the first argument is at least one level--- above the second argument.-ensureAbove :: (Eq a, Hashable a) => a -> a -> Order a -> Order a-ensureAbove child parent order =-    Map.insertWith max child (level parent order + 1) order---- | Reassign the parent for a child and recalculate the levels--- for the new parents and grandparents.-recalculateParent :: (Eq a, Hashable a)-    => a       -- Child.-    -> a       -- Parent.-    -> Graph a -- Query parents of a node. -    -> Order a -> Order a-recalculateParent child parent parents order-    | d <= 0    = order-    | otherwise = concatenate-        [ Map.insertWith (+) node (-d) | node <- dfs parent parents ]-        order-    where-    d = level parent order - level child order + 1-    -- level parent - d = level child - 1-    concatenate = foldr (.) id--{------------------------------------------------------------------------------    Graph traversal-------------------------------------------------------------------------------}--- | Graph represented as map of successors.-type Graph a = a -> [a]---- | Depth-first search. List all transitive successors of a node.-dfs :: (Eq a, Hashable a) => a -> Graph a -> [a]-dfs x succs = go [x] Set.empty-    where-    go []     _               = []-    go (x:xs) seen-        | x `Set.member` seen = go xs seen-        | otherwise           = x : go (ys ++ xs) (Set.insert x seen)-        where-        ys = succs x
− src/Reactive/Banana/Prim/Plumbing.hs 
@@ -1,163 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module Reactive.Banana.Prim.Plumbing where--import           Control.Monad-import           Control.Monad.Fix-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.RWS-import qualified Control.Monad.Trans.State as State-import           Data.Function-import           Data.Functor-import           Data.Functor.Identity-import           Data.List-import           Data.Monoid-import           Data.Unique.Really-import qualified Data.Vault.Lazy           as Lazy-import           System.IO.Unsafe                  (unsafePerformIO)--import           Reactive.Banana.Prim.Cached                (HasCache(..))-import qualified Reactive.Banana.Prim.Dated        as Dated-import qualified Reactive.Banana.Prim.Dependencies as Deps-import           Reactive.Banana.Prim.Types--{------------------------------------------------------------------------------    Build primitive pulses and latches-------------------------------------------------------------------------------}--- | Make 'Pulse' from evaluation function-newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)-newPulse name eval = unsafePerformIO $ do-    key <- Lazy.newKey-    uid <- newUnique-    return $ do-        let write = maybe (return Deps.Done) ((Deps.Children <$) . writePulseP key)-        return $ Pulse-            { evaluateP = {-# SCC evaluateP #-} write =<< eval-            , getValueP = Lazy.lookup key-            , uidP      = uid-            , nameP     = name-            }---- | 'Pulse' that never fires.-neverP :: Build (Pulse a)-neverP = unsafePerformIO $ do-    uid <- newUnique-    return $ return $ Pulse-        { evaluateP = return Deps.Done-        , getValueP = const Nothing-        , uidP      = uid-        , nameP     = "neverP"-        }---- | Make new 'Latch' that can be updated.-newLatch :: a -> Build (Pulse a -> Build (), Latch a)-newLatch a = unsafePerformIO $ do-    key <- Dated.newKey-    uid <- newUnique-    return $ do-        let-            write time   = maybe mempty (Endo . Dated.update' key time)-            latchWrite p = LatchWrite-                { evaluateL = {-# SCC evaluateL #-} do-                    time <- lift $ nTime <$> get-                    write (Dated.next time) <$> readPulseP p-                , uidL      = uid-                }-            updateOn p   = P p `addChild` L (latchWrite p)-        return-            (updateOn, Latch { getValueL = Dated.findWithDefault a key })---- | Make a new 'Latch' that caches a previous computation-cachedLatch :: Dated.Dated (Dated.Box a) -> Latch a-cachedLatch eval = unsafePerformIO $ do-    key <- Dated.newKey-    return $ Latch { getValueL = {-# SCC getValueL #-} Dated.cache key eval }---- | Add a new output that depends on a 'Pulse'.------ TODO: Return function to unregister the output again.-addOutput :: Pulse EvalO -> Build ()-addOutput p = unsafePerformIO $ do-    uid <- newUnique-    return $ do-        pos <- grOutputCount . nGraph <$> get-        let o = Output-                { evaluateO = {-# SCC evaluateO #-} maybe nop id <$> readPulseP p-                , uidO      = uid-                , positionO = pos-                }-        modify $ updateGraph $ updateOutputCount $ (+1)-        P p `addChild` O o--{------------------------------------------------------------------------------    Build monad - add and delete nodes from the graph-------------------------------------------------------------------------------}-runBuildIO :: Network -> BuildIO a -> IO (a, Network)-runBuildIO s1 m = {-# SCC runBuildIO #-} do-    (a,s2,liftIOLaters) <- runRWST m () s1-    sequence_ liftIOLaters          -- execute late IOs-    return (a,s2)---- Lift a pure  Build  computation into any monad.--- See note [BuildT]-liftBuild :: Monad m => Build a -> BuildT m a-liftBuild m = RWST $ \r s -> return . runIdentity $ runRWST m r s--readLatchB :: Latch a -> Build a-readLatchB latch = state $ \network ->-    let (a,v) = Dated.runDated (getValueL latch) (nLatchValues network)-    in  (Dated.unBox a, network { nLatchValues = v } )--alwaysP :: Build (Pulse ())-alwaysP = grAlwaysP . nGraph <$> get--instance (MonadFix m, Functor m) => HasCache (BuildT m) where-    retrieve key = Lazy.lookup key . grCache . nGraph <$> get-    write key a  = modify $ updateGraph $ updateCache $ Lazy.insert key a--dependOn :: Pulse child -> Pulse parent -> Build ()-dependOn child parent = (P parent) `addChild` (P child)--changeParent :: Pulse child -> Pulse parent -> Build ()-changeParent child parent =-    modify . updateGraph . updateDeps $ Deps.changeParent (P child) (P parent)--addChild :: SomeNode -> SomeNode -> Build ()-addChild parent child =-    modify . updateGraph . updateDeps $ Deps.addChild parent child--liftIOLater :: IO () -> Build ()-liftIOLater x = tell [x]--{------------------------------------------------------------------------------    EvalP - evaluate pulses-------------------------------------------------------------------------------}-runEvalP :: Lazy.Vault -> EvalP (EvalL, [(Position, EvalO)])-    -> BuildIO (Lazy.Vault, EvalL, EvalO)-runEvalP pulse m = do-        ((wl,wo),s) <- State.runStateT m pulse-        return (s,wl, sequence_ <$> sequence (sortOutputs wo))-    where-    sortOutputs = map snd . sortBy (compare `on` fst)--readLatchP :: Latch a -> EvalP a-readLatchP = {-# SCC readLatchP #-} lift . liftBuild . readLatchB--readLatchFutureP :: Latch a -> EvalP (Future a)-readLatchFutureP latch = State.state $ \s -> (Dated.unBox <$> getValueL latch,s)--writePulseP :: Lazy.Key a -> a -> EvalP ()-writePulseP key a = {-# SCC writePulseP #-} State.modify $ Lazy.insert key a--readPulseP :: Pulse a -> EvalP (Maybe a)-readPulseP pulse = {-# SCC readPulseP #-} getValueP pulse <$> State.get--liftBuildIOP :: BuildIO a -> EvalP a-liftBuildIOP = lift--liftBuildP :: Build a -> EvalP a-liftBuildP = liftBuildIOP . liftBuild--
− src/Reactive/Banana/Prim/Test.hs 
@@ -1,37 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Test where--import Control.Applicative-import Reactive.Banana.Prim--main = test_space1--{------------------------------------------------------------------------------    Functionality tests-------------------------------------------------------------------------------}-test_accumL1 :: Pulse Int -> BuildIO (Pulse Int)-test_accumL1 p1 = liftBuild $ do-    p2     <- mapP (+) p1-    (l1,_) <- accumL 0 p2-    let l2 =  mapL const l1-    p3     <- applyP l2 p1-    return p3--test_recursion1 :: Pulse () -> BuildIO (Pulse Int)-test_recursion1 p1 = liftBuild $ mdo-    p2      <- applyP l2 p1-    p3      <- mapP (const (+1)) p2-    ~(l1,_) <- accumL (0::Int) p3-    let l2  =  mapL const l1-    return p2--{------------------------------------------------------------------------------    Space leak tests-------------------------------------------------------------------------------}-test_space1 = runSpaceProfile test_accumL1    $ [1..2*10^4]-test_space2 = runSpaceProfile test_recursion1 $ () <$ [1..2*10^4]--
− src/Reactive/Banana/Prim/Types.hs 
@@ -1,194 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE ExistentialQuantification #-}-module Reactive.Banana.Prim.Types where--import           Control.Monad.Trans.Class-import           Control.Monad.Trans.RWS.Lazy-import           Control.Monad.Trans.State-import           Data.Functor.Identity-import qualified Data.HashMap.Strict          as Map-import qualified Data.HashSet                 as Set-import           Data.Hashable-import           Data.Monoid-import           Data.Unique.Really-import qualified Data.Vault.Lazy              as Lazy-import           System.IO.Unsafe                       (unsafePerformIO)--import           Reactive.Banana.Prim.Cached-import qualified Reactive.Banana.Prim.Dated        as Dated-import qualified Reactive.Banana.Prim.Dependencies as Deps--type Deps = Deps.Deps--{------------------------------------------------------------------------------    Graph-------------------------------------------------------------------------------}--- | A 'Graph' represents the connections between pulses and events.-data Graph = Graph-    { grDeps        :: Deps SomeNode   -- dependency information-    , grCache       :: Lazy.Vault      -- cache for the monad-    , grAlwaysP     :: Pulse ()        -- special pulse that always fires-    , grOutputCount :: !Position       -- ensure declaration order-    }-type Position = Integer--instance Show Graph where show = showDeps . grDeps---- | A 'Network' represents the state of a pulse/latch network,--- which consists of a 'Graph' and the values of all accumulated latches--- in the network.-data Network = Network-    { nGraph       :: Graph-    , nLatchValues :: Dated.Vault-    , nTime        :: Dated.Time-    }--instance Show Network where show = show . nGraph--type Inputs        = (Lazy.Vault, [SomeNode])-type EvalNetwork a = Network -> IO (a, Network)-type Step          = EvalNetwork (IO ())---- | Lenses for the 'Graph' and the 'Network' type-updateGraph       f = \s -> s { nGraph       = f (nGraph s) }-updateLatchValues f = \s -> s { nLatchValues = f (nLatchValues s) }-updateDeps        f = \s -> s { grDeps       = f (grDeps s) }-updateCache       f = \s -> s { grCache      = f (grCache s) }-updateOutputCount f = \s -> s { grOutputCount = f (grOutputCount s) }--emptyGraph :: Graph-emptyGraph = unsafePerformIO $ do-    uid <- newUnique-    return $ Graph-        { grDeps        = Deps.empty-        , grCache       = Lazy.empty-        , grAlwaysP     = Pulse-            { evaluateP = return Deps.Children-            , getValueP = const $ Just ()-            , uidP      = uid-            , nameP     = "alwaysP"-            }-        , grOutputCount = 0-        }---- | The 'Network' that contains no pulses or latches.-emptyNetwork :: Network-emptyNetwork = Network-    { nGraph       = emptyGraph-    , nLatchValues = Dated.empty-    , nTime        = Dated.beginning-    }---- The 'Build' monad is used to change the graph, for example to--- * add nodes--- * change dependencies--- * add inputs or outputs-type BuildT  = RWST () BuildConf Network-type Build   = BuildT Identity -type BuildIO = BuildT IO--type BuildConf = [IO ()] -- liftIOLater--{- Note [BuildT]--It is very convenient to be able to perform some IO functions-while (re)building a network graph. At the same time,-we need a good  MonadFix  instance to build recursive networks.-These requirements clash, so the solution is to split the types-into a pure variant and IO variant, the former having a good-MonadFix  instance while the latter can do arbitrary IO.---}--{------------------------------------------------------------------------------    Pulse and Latch-------------------------------------------------------------------------------}-{--    evaluateL/P-        calculates the next value and makes sure that it's cached-    getValueL/P-        retrieves the current value-    uidL/P-        used for dependency tracking and evaluation order-    nameP-        used for debugging--}--data Pulse a = Pulse-    { evaluateP :: EvalP Deps.Continue-    , getValueP :: Lazy.Vault -> Maybe a-    , uidP      :: Unique-    , nameP     :: String-    }--data Latch a = Latch-    { getValueL :: Future (Dated.Box a)-    }--data LatchWrite = LatchWrite-    { evaluateL :: EvalP EvalL-    , uidL      :: Unique-    }--data Output = Output-    { evaluateO :: EvalP EvalO-    , uidO      :: Unique-    , positionO :: Position-    }--type EvalP = StateT Lazy.Vault BuildIO-    -- state: current pulse values--type Future = Dated.Dated-type EvalL  = Endo Dated.Vault-type EvalO  = Future (IO ())--nop :: EvalO-nop = return $ return ()---- | Existential quantification for dependency tracking-data SomeNode-    = forall a. P (Pulse a)-    | L LatchWrite-    | O Output--instance Show SomeNode where show = show . hash--instance Eq SomeNode where-    (P x) == (P y)  =  uidP x == uidP y-    (L x) == (L y)  =  uidL x == uidL y-    (O x) == (O y)  =  uidO x == uidO y-    _     == _      =  False--uid :: SomeNode -> Unique-uid (P x) = uidP x-uid (L x) = uidL x-uid (O x) = uidO x--instance Hashable SomeNode where-    hashWithSalt s = hashWithSalt s . uid--{------------------------------------------------------------------------------    Show functions for debugging-------------------------------------------------------------------------------}-showDeps :: Deps SomeNode -> String-showDeps deps = unlines $-        [ detail node ++-          if null children then "" else " -> " ++ unwords (map short children)-        | node <- nodes-        , let children = Deps.children deps node-        ]-    where-    allChildren = Deps.allChildren deps-    nodes       = Set.toList . Set.fromList $-                  concat [x : xs | (x,xs) <- allChildren]-    dictionary  = Map.fromList $ zip nodes [1..]-    -    short node = maybe "X" show $ Map.lookup node dictionary-    -    detail (P x) = "P " ++ nameP x ++ " " ++ short (P x)-    detail (L x) = "L " ++ short (L x)-    detail (O x) = "O " ++ short (O x)-
− src/Reactive/Banana/Switch.hs 
@@ -1,106 +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.Combinators as Prim-import           Reactive.Banana.Types--{------------------------------------------------------------------------------    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 relying on the monad instance.-instance Functor (AnyMoment Identity) where-    fmap = liftM---- | Instance relying on the monad instance.-instance Applicative (AnyMoment Identity) where-    pure = return-    (<*>) = ap--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--instance Functor (AnyMoment Event) where-    fmap f (AnyMoment x) = AnyMoment (fmap (fmap 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,200 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Test cases and examples-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}--import Control.Arrow-import Control.Monad (when, join)--import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.HUnit (testCase)--import Test.HUnit (assert, Assertion)---- import Test.QuickCheck--- import Test.QuickCheck.Property--import Control.Applicative-import Reactive.Banana.Test.Plumbing---main = defaultMain-    [ testGroup "Simple"-        [ testModelMatch "id"      id-        -- , testModelMatch "never1"  never1-        , testModelMatch "fmap1"   fmap1-        , testModelMatch "filter1" filter1-        , testModelMatch "filter2" filter2-        , testModelMatch "accumE1" accumE1-        ]-    , testGroup "Complex"-        [ testModelMatch "counter"     counter-        , testModelMatch "double"      double-        , testModelMatch "sharing"     sharing-        , testModelMatch "recursive1"  recursive1-        , testModelMatch "recursive2"  recursive2-        , testModelMatch "recursive3"  recursive3-        , testModelMatch "recursive4a" recursive4a-        , testModelMatch "recursive4b" recursive4b-        , 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---- Recursive 4 is an example reported by Merijn Verstraaten---   https://github.com/HeinrichApfelmus/reactive-banana/issues/56--- Minimization:-recursive4a :: Event Int -> Event (Bool, Int)-recursive4a eInput = resultB <@ eInput-    where-    resultE     = resultB <@ eInput-    resultB     = (,) <$> focus <*> pureB 0-    focus       = stepperB False $ fst <$> resultE--- 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 -> 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,107 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}--- * Synopsis--- | Merge model and implementation into a single type. Not pretty.--module Reactive.Banana.Test.Plumbing where--import Control.Applicative-import Control.Monad (liftM, ap)-import Control.Monad.Fix--import qualified Reactive.Banana.Model as X-import qualified Reactive.Banana.Internal.Combinators as Y--{------------------------------------------------------------------------------    Types as pairs-------------------------------------------------------------------------------}--data Event    a = E (X.Event    a) (Y.Event    a)-data Behavior a = B (X.Behavior a) (Y.Behavior a)-data Moment   a = M (X.Moment   a) (Y.Moment   a)---- pair extractions-fstE (E x _) = x; sndE (E _ y) = y-fstB (B x _) = x; sndB (B _ y) = y-fstM (M x _) = x; sndM (M _ y) = y---- partial embedding functions-ex x = E x undefined; ey y = E undefined y-bx x = B x undefined; by y = B undefined y-mx x = M x undefined; my y = M undefined y---- interpretation-interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]-interpretModel f = X.interpret (fmap fstE . fstM . f . ex)--interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey)--{------------------------------------------------------------------------------    Primitive combinators-------------------------------------------------------------------------------}-never                           = E X.never Y.never-filterJust (E x y)              = E (X.filterJust x) (Y.filterJust y)-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 Applicative Moment where-    pure  = return-    (<*>) = ap-instance Monad Moment where-    return a = M (return a) (return a)-    (M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g)-instance MonadFix Moment where-    mfix f = M (mfix fx) (mfix fy)-        where-        fx a = let M x _ = f a in x-        fy a = let M _ y = f a in y--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)--infixl 4 <@>, <@-b <@ e  = applyE (const <$> b) e-b <@> e = applyE b e
src/Reactive/Banana/Types.hs view
@@ -1,35 +1,160 @@+{-# language CPP #-}+ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Types (     -- | Primitive types.-    Event (..), Behavior (..), Moment (..), Future(..)+    Event(..), Behavior(..),+    Moment(..), MomentIO(..), MonadMoment(..),+    Future(..),     ) where  import Control.Applicative-import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix+import Data.String (IsString(..))+import Control.Monad.Trans.Accum (AccumT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) -import qualified Reactive.Banana.Internal.Combinators as Prim-import           Reactive.Banana.Internal.Phantom+#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 -{-| @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,+import qualified Reactive.Banana.Prim.High.Combinators as Prim -> type Event t a = [(Time,a)]+{-----------------------------------------------------------------------------+    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 t a = E { unE :: Prim.Event [a] }+newtype Event a = E { unE :: Prim.Event a }+-- Invariant: The empty list `[]` never occurs as event value. -{-| @Behavior t a@ represents a value that varies in time. Think of it as+-- | 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 -> type Behavior t a = Time -> a+-- | 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 t a = B { unB :: Prim.Behavior a }+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 }@@ -38,43 +163,87 @@ instance Functor Future where fmap f = F . fmap f . unF  instance Monad Future where-    return  = F . return     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 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.+{-| The 'Moment' monad denotes a /pure/ computation that happens+at one particular moment in time. Semantically, it is a reader monad -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.+> type Moment a = Time -> a -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@.+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 t a = M { unM :: Prim.Moment a }+newtype Moment a = M { unM :: Prim.Moment a } --- boilerplate class instances-instance Functor (Moment t) where fmap f = M . fmap f . unM+{-| The 'MomentIO' monad is used to add inputs and outputs+to an event network.+-}+newtype MomentIO a = MIO { unMIO :: Prim.Moment a } -instance Monad (Moment t) where-    return  = M . return-    m >>= g = M $ unM m >>= unM . g+instance MonadIO MomentIO where liftIO = MIO . liftIO -instance Applicative (Moment t) where+{-| 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 MonadFix (Moment t) 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 Frameworks t => MonadIO (Moment t) where-    liftIO = M . Prim.liftIONow++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