packages feed

reactive-banana 1.2.2.0 → 1.3.2.0

raw patch · 51 files changed

Files

CHANGELOG.md view
@@ -1,6 +1,47 @@-Changelog for the `reactive-banana** package+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][]@@ -21,7 +62,6 @@   [#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**
+ 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 []       = []
reactive-banana.cabal view
@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             1.2.2.0+Version:             1.3.2.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).@@ -25,13 +25,15 @@ Category:            FRP Cabal-version:       1.18 Build-type:          Simple-Tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 8.0.1,-                     GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1+Tested-with:         GHC == 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@@ -44,13 +46,15 @@     hs-source-dirs:     src      build-depends:      base >= 4.2 && < 5,-                        semigroups >= 0.13 && < 0.20,+                        deepseq >= 1.4.3.0 && < 1.5,+                        semigroups >= 0.13 && < 0.21,                         containers >= 0.5 && < 0.7,-                        transformers >= 0.2 && < 0.6,+                        transformers >= 0.2 && < 0.7,                         vault == 0.3.*,                         unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.4,+                        hashable >= 1.1 && < 1.5,                         pqueue >= 1.0 && < 1.5,+                        stm >= 2.5 && < 2.6,                         these >= 0.2 && < 1.2      exposed-modules:@@ -59,35 +63,81 @@                         Reactive.Banana.Combinators,                         Reactive.Banana.Frameworks,                         Reactive.Banana.Model,-                        Reactive.Banana.Prim,-                        Reactive.Banana.Prim.Cached+                        Reactive.Banana.Prim.Mid,+                        Reactive.Banana.Prim.High.Cached,+                        Reactive.Banana.Prim.Low.Graph,+                        Reactive.Banana.Prim.Low.GraphGC,+                        Reactive.Banana.Prim.Low.Ref      other-modules:                         Control.Monad.Trans.ReaderWriterIO,                         Control.Monad.Trans.RWSIO,-                        Reactive.Banana.Internal.Combinators,-                        Reactive.Banana.Prim.Combinators,-                        Reactive.Banana.Prim.Compile,-                        Reactive.Banana.Prim.Dependencies,-                        Reactive.Banana.Prim.Evaluation,-                        Reactive.Banana.Prim.Graph,-                        Reactive.Banana.Prim.IO,-                        Reactive.Banana.Prim.OrderedBag,-                        Reactive.Banana.Prim.Plumbing,-                        Reactive.Banana.Prim.Test,-                        Reactive.Banana.Prim.Types,-                        Reactive.Banana.Prim.Util,+                        Reactive.Banana.Prim.Low.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,-                        semigroups, transformers,-                        unordered-containers, hashable, psqueues, pqueue, these+    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
@@ -9,12 +9,11 @@     ) where  +import           Control.Monad ((>=>), when) import           Data.IORef import qualified Data.Map    as Map import qualified Data.Unique -type Map = Map.Map- {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}@@ -40,12 +39,12 @@  -- | Map the event value with an 'IO' action. mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b-mapIO f e = AddHandler $ \h -> register e $ \x -> f x >>= h+mapIO f e = AddHandler $ \h -> register e (f >=> h)  -- | Filter event values that don't return 'True'. filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a filterIO f e = AddHandler $ \h ->-    register e $ \x -> f x >>= \b -> if b then h x else return ()+    register e $ \x -> f x >>= \b -> when b $ h x  {-----------------------------------------------------------------------------     Construction@@ -68,8 +67,29 @@             atomicModifyIORef_ handlers $ Map.insert key handler             return $ atomicModifyIORef_ handlers $ Map.delete key         runHandlers a =-            mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers+            runAll a =<< readIORef handlers     return (AddHandler register, runHandlers)  atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())++-- | A callback is a @a -> IO ()@ function. We define this newtype to provide+-- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which+-- allow us to write the efficient 'runAll' function.+newtype Callback a = Callback { invoke :: a -> IO () }++instance Semigroup (Callback a) where+    Callback f <> Callback g = Callback $ \a -> f a >> g a++instance Monoid (Callback a) where+    mempty = Callback $ \_ -> return ()++-- This function can also be seen as+--+--   runAll a fs = mapM_ ($ a) fs+--+-- The reason we write this using 'foldMap' and 'Callback' is to produce code+-- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237+-- for more info.+runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO ()+runAll a fs = invoke (foldMap Callback fs) a
src/Control/Monad/Trans/RWSIO.hs view
@@ -7,13 +7,10 @@     RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put,     ) where -import Control.Applicative-import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.IORef-import Data.Monoid  {-----------------------------------------------------------------------------     Type and class instances@@ -29,7 +26,6 @@     (<*>) = apR  instance Monad m => Monad (RWSIOT r w s m) where-    return = returnR     (>>=)  = bindR  instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR@@ -48,9 +44,6 @@ 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) -returnR :: Monad m => a -> RWSIOT r w s m a-returnR a = R $ \_ -> return a- 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 @@ -92,8 +85,3 @@  put :: MonadIO m => s -> RWSIOT r w s m () put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s--test :: RWSIOT String String () IO ()-test = do-    c <- ask-    tell c
src/Control/Monad/Trans/ReaderWriterIO.hs view
@@ -8,14 +8,10 @@     ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local,     ) where -import Control.Applicative-import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.IORef-import Data.Monoid-import Data.Semigroup  {-----------------------------------------------------------------------------     Type and class instances@@ -29,7 +25,6 @@     (<*>) = apR  instance Monad m => Monad (ReaderWriterIOT r w m) where-    return = returnR     (>>=)  = bindR  instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR@@ -40,24 +35,21 @@     mx <> my = mx >> my  instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where-    mempty          = return ()-    mx `mappend` my = mx >> my+    mempty  = return ()+    mappend = (<>)  {-----------------------------------------------------------------------------     Functions ------------------------------------------------------------------------------} liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a-liftIOR m = ReaderWriterIOT $ \x y -> liftIO m+liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m  liftR :: m a -> ReaderWriterIOT r w m a-liftR m = ReaderWriterIOT $ \x y -> m+liftR m = ReaderWriterIOT $ \_ _ -> m  fmapR :: Functor m => (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y) -returnR :: Monad m => a -> ReaderWriterIOT r w m a-returnR a = ReaderWriterIOT $ \_ _ -> return a- 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 @@ -99,8 +91,3 @@  ask :: Monad m => ReaderWriterIOT r w m r ask = ReaderWriterIOT $ \r _ -> return r--test :: ReaderWriterIOT String String IO ()-test = do-    c <- ask-    tell c
src/Reactive/Banana.hs view
@@ -19,7 +19,6 @@  import Reactive.Banana.Combinators import Reactive.Banana.Frameworks-import Reactive.Banana.Types  {-$intro
src/Reactive/Banana/Combinators.hs view
@@ -2,6 +2,7 @@     reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Reactive.Banana.Combinators (@@ -34,9 +35,9 @@      -- * Derived Combinators     -- ** Infix operators-    (<@>), (<@),+    (<@>), (<@), (@>),     -- ** Filtering-    filterJust, filterApply, whenE, split,+    filterJust, filterApply, whenE, split, once,     -- ** Accumulation     -- $Accumulation.     unions, accumB, mapAccum,@@ -45,12 +46,10 @@     ) where  import Control.Applicative-import Control.Monad-import Data.Maybe          (isJust, catMaybes) import Data.Semigroup-import Data.These (These(..), these)+import Data.These (These(..)) -import qualified Reactive.Banana.Internal.Combinators as Prim+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  {-----------------------------------------------------------------------------@@ -277,12 +276,15 @@ -- | Dynamically switch between 'Event'. -- Semantically, ----- > switchE ee = \time0 -> concat [trim t1 t2 e | (t1,t2,e) <- intervals ee, time0 <= t1]--- >     where--- >     intervals e        = [(time1, time2, x) | ((time1,x),(time2,_)) <- zip e (tail e)]+-- > switchE e0 ee0 time0 =+-- >     concat [ trim t1 t2 e | (t1,t2,e) <- intervals ee ]+-- >   where+-- >     laterThan e time0  = [(timex,x) | (timex,x) <- e, time0 < timex ]+-- >     ee                 = [(time0, e0)] ++ (ee0 `laterThan` time0)+-- >     intervals ee       = [(time1, time2, e) | ((time1,e),(time2,_)) <- zip ee (tail ee)] -- >     trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2]-switchE :: MonadMoment m => Event (Event a) -> m (Event a)-switchE = liftMoment . M . fmap E . Prim.switchE . Prim.mapE (unE) . unE+switchE :: MonadMoment m => Event a -> Event (Event a) -> m (Event a)+switchE e ee = liftMoment (M (fmap E (Prim.switchE (unE e) (Prim.mapE unE (unE ee)))))  -- | Dynamically switch between 'Behavior'. -- Semantically,@@ -290,12 +292,12 @@ -- >  switchB b0 eb = \time0 -> \time1 -> -- >     last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1 switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a)-switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE (unB) . unE+switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE unB . unE  {-----------------------------------------------------------------------------     Derived Combinators ------------------------------------------------------------------------------}-infixl 4 <@>, <@+infixl 4 <@>, <@, @>  -- | Infix synonym for the 'apply' combinator. Similar to '<*>'. --@@ -309,6 +311,20 @@ (<@)  :: Behavior b -> Event a -> Event b f <@ g = (const <$> f) <@> g +-- | Tag all event occurences with a time-varying value. Similar to '*>'.+--+-- This is the flipped version of '<@', but can be useful when combined with+-- @ApplicativeDo@ to sample from multiple 'Behavior's:+--+-- @+-- reactimate $ onEvent @> do+--   x <- behavior1+--   y <- behavior2+--   return (print (x + y))+-- @+(@>) :: Event a -> Behavior b -> Event b+g @> f = (const <$> f) <@> g+ -- | Allow all events that fulfill the time-varying predicate, discard the rest. -- Generalization of 'filterE'. filterApply :: Behavior (a -> Bool) -> Event a -> Event a@@ -327,11 +343,22 @@     where     fromLeft :: Either a b -> Maybe a     fromLeft  (Left  a) = Just a-    fromLeft  (Right b) = Nothing+    fromLeft  (Right _) = Nothing      fromRight :: Either a b -> Maybe b-    fromRight (Left  a) = Nothing+    fromRight (Left  _) = Nothing     fromRight (Right b) = Just b+++-- | Keep only the next occurence of an event.+-- +-- @once@ also aids the garbage collector by indicating that the result event can be discarded after its only occurrence.+--+-- > once e = \time0 -> take 1 [(t, a) | (t, a) <- e, time0 <= t]+once :: MonadMoment m => Event a -> m (Event a)+once e = mdo+    e1 <- switchE e (never <$ e1)+    return e1   -- $Accumulation.
src/Reactive/Banana/Frameworks.hs view
@@ -33,7 +33,7 @@     interpretFrameworks, newEvent, mapEventIO, newBehavior,      -- * Running event networks-    EventNetwork, actuate, pause,+    EventNetwork, actuate, pause, getSize,      ) where @@ -42,7 +42,7 @@ import           Control.Monad.IO.Class import           Data.IORef import           Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.Combinators as Prim+import qualified Reactive.Banana.Prim.High.Combinators as Prim import           Reactive.Banana.Types  @@ -332,6 +332,12 @@ pause :: EventNetwork -> IO () pause   = Prim.pause . unEN +-- | PROVISIONAL.+-- Measure of the number of events in the event network.+-- Useful for understanding space usage.+getSize :: EventNetwork -> IO Int+getSize = Prim.getSize . unEN+ {-----------------------------------------------------------------------------     Utilities ------------------------------------------------------------------------------}@@ -342,7 +348,7 @@ -- inside a 'reactimate'. newEvent :: MomentIO (Event a, Handler a) newEvent = do-    (addHandler, fire) <- liftIO $ newAddHandler+    (addHandler, fire) <- liftIO newAddHandler     e <- fromAddHandler addHandler     return (e,fire) @@ -377,7 +383,7 @@ mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b) mapEventIO f e1 = do     (e2, handler) <- newEvent-    reactimate $ (\a -> f a >>= handler) <$> e1+    reactimate $ (f >=> handler) <$> e1     return e2  {-----------------------------------------------------------------------------@@ -396,7 +402,7 @@         reactimate $ writeIORef output . Just <$> e2      actuate network-    bs <- forM xs $ \x -> do+    forM xs $ \x -> do         case x of             Nothing -> return Nothing             Just x  -> do@@ -404,7 +410,6 @@                 b <- readIORef output                 writeIORef output Nothing                 return b-    return bs  -- | Simple way to write a single event handler with -- functional reactive programming.
− src/Reactive/Banana/Internal/Combinators.hs 
@@ -1,246 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-}-module Reactive.Banana.Internal.Combinators where--import           Control.Concurrent.MVar-import           Control.Event.Handler-import           Control.Monad-import           Control.Monad.Fix-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class           (lift)-import           Control.Monad.Trans.Reader-import           Data.Functor-import           Data.Functor.Identity-import           Data.IORef-import qualified Reactive.Banana.Prim        as Prim-import           Reactive.Banana.Prim.Cached-import           Data.These (These(..), these)--type Build   = Prim.Build-type Latch a = Prim.Latch a-type Pulse a = Prim.Pulse a-type Future  = Prim.Future--{------------------------------------------------------------------------------    Types-------------------------------------------------------------------------------}-type Behavior a = Cached Moment (Latch a, Pulse ())-type Event a    = Cached Moment (Pulse a)-type Moment     = ReaderT EventNetwork Prim.Build--liftBuild :: Build a -> Moment a-liftBuild = lift--{------------------------------------------------------------------------------    Interpretation-------------------------------------------------------------------------------}-interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined-    where-    g pulse = runCached =<< f (Prim.fromPure pulse)-    -- Ignore any  addHandler  inside the  Moment--{------------------------------------------------------------------------------    IO-------------------------------------------------------------------------------}--- | Data type representing an event network.-data EventNetwork = EventNetwork-    { runStep :: Prim.Step -> IO ()-    , actuate :: IO ()-    , pause   :: IO ()-    }---- | Compile to an event network.-compile :: Moment () -> IO EventNetwork-compile setup = do-    actuated <- newIORef False                   -- flag to set running status-    s        <- newEmptyMVar                     -- setup callback machinery-    let-        whenFlag flag action = readIORef flag >>= \b -> when b action-        runStep f            = whenFlag actuated $ do-            s1 <- takeMVar s                    -- read and take lock-            -- pollValues <- sequence polls     -- poll mutable data-            (output, s2) <- f s1                -- calculate new state-            putMVar s s2                        -- write state-            output                              -- run IO actions afterwards--        eventNetwork = EventNetwork-            { runStep = runStep-            , actuate = writeIORef actuated True-            , pause   = writeIORef actuated False-            }--    (output, s0) <-                             -- compile initial graph-        Prim.compile (runReaderT setup eventNetwork) Prim.emptyNetwork-    putMVar s s0                                -- set initial state--    return $ eventNetwork--fromAddHandler :: AddHandler a -> Moment (Event a)-fromAddHandler addHandler = do-    (p, fire) <- liftBuild $ Prim.newInput-    network   <- ask-    liftIO $ register addHandler $ runStep network . fire-    return $ Prim.fromPure p--addReactimate :: Event (Future (IO ())) -> Moment ()-addReactimate e = do-    network   <- ask-    liftBuild $ Prim.buildLater $ do-        -- Run cached computation later to allow more recursion with `Moment`-        p <- runReaderT (runCached e) network-        Prim.addHandler p id--fromPoll :: IO a -> Moment (Behavior a)-fromPoll poll = do-    a <- liftIO poll-    e <- liftBuild $ do-        p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP-        return $ Prim.fromPure p-    stepperB a e--liftIONow :: IO a -> Moment a-liftIONow = liftIO--liftIOLater :: IO () -> Moment ()-liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater--imposeChanges :: Behavior a -> Event () -> Behavior a-imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2)--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-never :: Event a-never = don'tCache  $ liftBuild $ Prim.neverP--mergeWith-  :: (a -> c)-  -> (b -> c)-  -> (a -> b -> c)-  -> Event a-  -> Event b-  -> Event c-mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y))---filterJust :: Event (Maybe a) -> Event a-filterJust  = liftCached1 $ liftBuild . Prim.filterJustP--mapE :: (a -> b) -> Event a -> Event b-mapE f = liftCached1 $ liftBuild . Prim.mapP f--applyE :: Behavior (a -> b) -> Event a -> Event b-applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px--changesB :: Behavior a -> Event (Future a)-changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px--pureB :: a -> Behavior a-pureB a = cache $ do-    p <- runCached never-    return (Prim.pureL a, p)--applyB :: Behavior (a -> b) -> Behavior a -> Behavior b-applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do-    p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2-    let l3 = Prim.applyL l1 l2-    return (l3,p3)--mapB :: (a -> b) -> Behavior a -> Behavior b-mapB f = applyB (pureB f)--{------------------------------------------------------------------------------    Combinators - accumulation-------------------------------------------------------------------------------}--- Make sure that the cached computation (Event or Behavior)--- is executed eventually during this moment.-trim :: Cached Moment a -> Moment (Cached Moment a)-trim b = do-    liftBuildFun Prim.buildLater $ void $ runCached b-    return b---- Cache a computation at this moment in time--- and make sure that it is performed in the Build monad eventually-cacheAndSchedule :: Moment a -> Moment (Cached Moment a)-cacheAndSchedule m = ask >>= \r -> liftBuild $ do-    let c = cache (const m r)   -- prevent let-floating!-    Prim.buildLater $ void $ runReaderT (runCached c) r-    return c--stepperB :: a -> Event a -> Moment (Behavior a)-stepperB a e = cacheAndSchedule $ do-    p0 <- runCached e-    liftBuild $ do-        p1    <- Prim.mapP const p0-        p2    <- Prim.mapP (const ()) p1-        (l,_) <- Prim.accumL a p1-        return (l,p2)--accumE :: a -> Event (a -> a) -> Moment (Event a)-accumE a e1 = cacheAndSchedule $ do-    p0 <- runCached e1-    liftBuild $ do-        (_,p1) <- Prim.accumL a p0-        return p1--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-liftBuildFun :: (Build a -> Build b) -> Moment a -> Moment b-liftBuildFun f m = do-    r <- ask-    liftBuild $ f $ runReaderT m r--valueB :: Behavior a -> Moment a-valueB b = do-    ~(l,_) <- runCached b-    liftBuild $ Prim.readLatch l--initialBLater :: Behavior a -> Moment a-initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB--executeP :: Pulse (Moment a) -> Moment (Pulse a)-executeP p1 = do-    r <- ask-    liftBuild $ do-        p2 <- Prim.mapP runReaderT p1-        Prim.executeP p2 r--observeE :: Event (Moment a) -> Event a-observeE = liftCached1 $ executeP--executeE :: Event (Moment a) -> Moment (Event a)-executeE e = do-    -- Run cached computation later to allow more recursion with `Moment`-    p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e-    return $ fromPure p--switchE :: Event (Event a) -> Moment (Event a)-switchE e = ask >>= \r -> cacheAndSchedule $ do-    p1 <- runCached e-    liftBuild $ do-        p2 <- Prim.mapP (runReaderT . runCached) p1-        p3 <- Prim.executeP p2 r-        Prim.switchP p3--switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)-switchB b e = ask >>= \r -> cacheAndSchedule $ do-    ~(l0,p0) <- runCached b-    p1       <- runCached e-    liftBuild $ do-        p2 <- Prim.mapP (runReaderT . runCached) p1-        p3 <- Prim.executeP p2 r--        lr <- Prim.switchL l0 =<< Prim.mapP fst p3-        -- TODO: switch away the initial behavior-        let c1 = p0                              -- initial behavior changes-        c2 <- Prim.mapP (const ()) p3            -- or switch happens-        c3 <- Prim.switchP =<< Prim.mapP snd p3  -- or current behavior changes-        pr <- merge c1 =<< merge c2 c3-        return (lr, pr)--merge :: Pulse () -> Pulse () -> Build (Pulse ())-merge = Prim.mergeWithP Just Just (\_ _ -> Just ())
src/Reactive/Banana/Model.hs view
@@ -2,6 +2,8 @@     reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Reactive.Banana.Model (     -- * Synopsis     -- | Model implementation for learning and testing.@@ -27,6 +29,7 @@ import Control.Monad import Control.Monad.Fix import Data.These (These(..), these)+import Data.Maybe (fromMaybe)  {-$overview @@ -145,9 +148,7 @@ stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)     where     step i ~(x:xs) = i : step next xs-        where next = case x of-                        Just i  -> i-                        Nothing -> i+        where next = fromMaybe i x  -- Expressed using recursion and the other primitives -- FIXME: Strictness!@@ -166,9 +167,9 @@ observeE :: Event (Moment a) -> Event a observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE -switchE :: Event (Event a) -> Moment (Event a)-switchE es = M $ \t -> E $-    replicate t Nothing ++ switch (unE never) (forgetE t (forgetDiagonalE es))+switchE :: Event a -> Event (Event a) -> Moment (Event a)+switchE e es = M $ \t -> E $+    replicate t Nothing ++ switch (unE e) (forgetE t (forgetDiagonalE es))     where     switch (x:xs) (Nothing : ys) = x : switch xs ys     switch (x: _) (Just xs : ys) = x : switch (tail xs) ys
− src/Reactive/Banana/Prim.hs 
@@ -1,119 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim (-    -- * Synopsis-    -- | This is an internal module, useful if you want to-    -- implemented your own FRP library.-    -- If you just want to use FRP in your project,-    -- have a look at "Reactive.Banana" instead.--    -- * Evaluation-    Step, Network, emptyNetwork,--    -- * Build FRP networks-    Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,-    module Control.Monad.IO.Class,--    -- * Caching-    module Reactive.Banana.Prim.Cached,--    -- * Testing-    interpret, mapAccumM, mapAccumM_, runSpaceProfile,--    -- * IO-    newInput, addHandler, readLatch,--    -- * Pulse-    Pulse,-    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP,--    -- * Latch-    Latch,-    pureL, mapL, applyL, accumL, applyP,--    -- * Dynamic event switching-    switchL, executeP, switchP--    -- * Notes-    -- $recursion-  ) where---import Control.Monad.IO.Class-import Reactive.Banana.Prim.Cached-import Reactive.Banana.Prim.Combinators-import Reactive.Banana.Prim.Compile-import Reactive.Banana.Prim.IO-import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater)-import Reactive.Banana.Prim.Types--{------------------------------------------------------------------------------    Notes-------------------------------------------------------------------------------}--- Note [Recursion]-{- $recursion--The 'Build' monad is an instance of 'MonadFix' and supports value recursion.-However, it is built on top of the 'IO' monad, so the recursion is-somewhat limited.--The main rule for value recursion in the 'IO' monad is that the action-to be performed must be known in advance. For instance, the following snippet-will not work, because 'putStrLn' cannot complete its action without-inspecting @x@, which is not defined until later.-->   mdo->       putStrLn x->       let x = "Hello recursion"--On the other hand, whenever the sequence of 'IO' actions can be known-before inspecting any later arguments, the recursion works.-For instance the snippet-->   mdo->       p1 <- mapP p2->       p2 <- neverP->       return p1--works because 'mapP' does not inspect its argument. In other words,-a call @p1 <- mapP undefined@ would perform the same sequence of 'IO' actions.-(Internally, it essentially calls 'newIORef'.)--With this issue in mind, almost all operations that build 'Latch'-and 'Pulse' values have been carefully implemented to not inspect-their arguments.-In conjunction with the 'Cached' mechanism for observable sharing,-this allows us to build combinators that can be used recursively.-One notable exception is the 'readLatch' function, which must-inspect its argument in order to be able to read its value.---}--test :: Build (Pulse ())-test = mdo-    p1 <- mapP (const ()) p2-    p2 <- neverP-    return p1---- Note [LatchStrictness]-{---Any value that is stored in the graph over a longer-period of time must be stored in WHNF.--This implies that the values in a latch must be forced to WHNF-when storing them. That doesn't have to be immediately-since we are tying a knot, but it definitely has to be done-before  evaluateGraph  is done.--It also implies that reading a value from a latch must-be forced to WHNF before storing it again, so that we don't-carry around the old collection of latch values.-This is particularly relevant for `applyL`.--Conversely, since latches are the only way to store values over time,-this is enough to guarantee that there are no space leaks in this regard.---}
− src/Reactive/Banana/Prim/Cached.hs 
@@ -1,65 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Cached (-    -- | Utility for executing monadic actions once-    -- and then retrieving values from a cache.-    ---    -- Very useful for observable sharing.-    Cached, runCached, cache, fromPure, don'tCache,-    liftCached1, liftCached2,-    ) where--import Control.Monad-import Control.Monad.Fix-import Control.Monad.IO.Class-import Data.IORef-import System.IO.Unsafe       (unsafePerformIO)--{------------------------------------------------------------------------------    Cache type-------------------------------------------------------------------------------}-data Cached m a = Cached (m a)--runCached :: Cached m a -> m a-runCached (Cached x) = x---- | An action whose result will be cached.--- Executing the action the first time in the monad will--- execute the side effects. From then on,--- only the generated value will be returned.-{-# NOINLINE cache #-}-cache :: (MonadFix m, MonadIO m) => m a -> Cached m a-cache m = unsafePerformIO $ do-    key <- liftIO $ newIORef Nothing-    return $ Cached $ do-        ma <- liftIO $ readIORef key    -- read the cached result-        case ma of-            Just a  -> return a         -- return the cached result.-            Nothing -> mdo-                liftIO $                -- write the result already-                    writeIORef key (Just a)-                a <- m                  -- evaluate-                return a---- | Return a pure value. Doesn't make use of the cache.-fromPure :: Monad m => a -> Cached m a-fromPure = Cached . return---- | Lift an action that is /not/ cached, for instance because it is idempotent.-don'tCache :: Monad m => m a -> Cached m a-don'tCache = Cached--liftCached1 :: (MonadFix m, MonadIO m) =>-    (a -> m b) -> Cached m a -> Cached m b-liftCached1 f ca = cache $ do-    a <- runCached ca-    f a--liftCached2 :: (MonadFix m, MonadIO m) =>-    (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c-liftCached2 f ca cb = cache $ do-    a <- runCached ca-    b <- runCached cb-    f a b
− src/Reactive/Banana/Prim/Combinators.hs 
@@ -1,150 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}-module Reactive.Banana.Prim.Combinators where--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class--import Reactive.Banana.Prim.Plumbing-    ( neverP, newPulse, newLatch, cachedLatch-    , dependOn, keepAlive, changeParent-    , getValueL-    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,-    )-import qualified Reactive.Banana.Prim.Plumbing (pureL)-import           Reactive.Banana.Prim.Types    (Latch, Future, Pulse, Build, EvalP)--import Debug.Trace--- debug s = trace s-debug s = id--{------------------------------------------------------------------------------    Combinators - basic-------------------------------------------------------------------------------}-mapP :: (a -> b) -> Pulse a -> Build (Pulse b)-mapP f p1 = do-    p2 <- newPulse "mapP" $ ({-# SCC mapP #-} fmap f <$> readPulseP p1)-    p2 `dependOn` p1-    return p2---- | Tag a 'Pulse' with future values of a 'Latch'.------ This is in contrast to 'applyP' which applies the current value--- of a 'Latch' to a pulse.-tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))-tagFuture x p1 = do-    p2 <- newPulse "tagFuture" $-        fmap . const <$> readLatchFutureP x <*> readPulseP p1-    p2 `dependOn` p1-    return p2--filterJustP :: Pulse (Maybe a) -> Build (Pulse a)-filterJustP p1 = do-    p2 <- newPulse "filterJustP" $ ({-# SCC filterJustP #-} join <$> readPulseP p1)-    p2 `dependOn` p1-    return p2--unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b)-unsafeMapIOP f p1 = do-        p2 <- newPulse "unsafeMapIOP" $-            ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1)-        p2 `dependOn` p1-        return p2-    where-    eval :: Maybe a -> EvalP (Maybe b)-    eval (Just x) = Just <$> liftIO (f x)-    eval Nothing  = return Nothing--mergeWithP-  :: (a -> Maybe c)-  -> (b -> Maybe c)-  -> (a -> b -> Maybe c)-  -> Pulse a-  -> Pulse b-  -> Build (Pulse c)-mergeWithP f g h px py = do-  p <- newPulse "mergeWithP" $-       ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py)-  p `dependOn` px-  p `dependOn` py-  return p-  where-    eval Nothing  Nothing  = Nothing-    eval (Just x) Nothing  = f x-    eval Nothing  (Just y) = g y-    eval (Just x) (Just y) = h x y---- See note [LatchRecursion]-applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)-applyP f x = do-    p <- newPulse "applyP" $-        ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x)-    p `dependOn` x-    return p--pureL :: a -> Latch a-pureL = Reactive.Banana.Prim.Plumbing.pureL---- specialization of   mapL f = applyL (pureL f)-mapL :: (a -> b) -> Latch a -> Latch b-mapL f lx = cachedLatch $ ({-# SCC mapL #-} f <$> getValueL lx)--applyL :: Latch (a -> b) -> Latch a -> Latch b-applyL lf lx = cachedLatch $-    ({-# SCC applyL #-} getValueL lf <*> getValueL lx)--accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)-accumL a p1 = do-    (updateOn, x) <- newLatch a-    p2 <- applyP (mapL (\x f -> f x) x) p1-    updateOn p2-    return (x,p2)---- specialization of accumL-stepperL :: a -> Pulse a -> Build (Latch a)-stepperL a p = do-    (updateOn, x) <- newLatch a-    updateOn p-    return x--{------------------------------------------------------------------------------    Combinators - dynamic event switching-------------------------------------------------------------------------------}-switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)-switchL l pl = mdo-    x <- stepperL l pl-    return $ cachedLatch $ getValueL x >>= getValueL--executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a)-executeP p1 b = do-        p2 <- newPulse "executeP" $ ({-# SCC executeP #-} eval =<< readPulseP p1)-        p2 `dependOn` p1-        return p2-    where-    eval :: Maybe (b -> Build a) -> EvalP (Maybe a)-    eval (Just x) = Just <$> liftBuildP (x b)-    eval Nothing  = return Nothing--switchP :: Pulse (Pulse a) -> Build (Pulse a)-switchP pp = mdo-    never <- neverP-    lp    <- stepperL never pp-    let-        -- switch to a new parent-        switch = do-            mnew <- readPulseP pp-            case mnew of-                Nothing  -> return ()-                Just new -> liftBuildP $ p2 `changeParent` new-            return Nothing-        -- fetch value from old parent-        eval = readPulseP =<< readLatchP lp--    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())-    p1 `dependOn` pp-    p2 <- newPulse "switchP_out" eval-    p2 `keepAlive` p1-    return p2
− src/Reactive/Banana/Prim/Compile.hs 
@@ -1,110 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}-module Reactive.Banana.Prim.Compile where--import Control.Exception (evaluate)-import Control.Monad     (void)-import Data.Functor-import Data.IORef--import           Reactive.Banana.Prim.Combinators-import           Reactive.Banana.Prim.IO-import qualified Reactive.Banana.Prim.OrderedBag  as OB-import           Reactive.Banana.Prim.Plumbing-import           Reactive.Banana.Prim.Types--{------------------------------------------------------------------------------   Compilation-------------------------------------------------------------------------------}--- | Change a 'Network' of pulses and latches by--- executing a 'BuildIO' action.-compile :: BuildIO a -> Network -> IO (a, Network)-compile m state1 = do-    let time1    = nTime state1-        outputs1 = nOutputs state1--    theAlwaysP <- case nAlwaysP state1 of-        Just x   -> return x-        Nothing  -> do-            (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())-            return x--    (a, topology, os) <- runBuildIO (nTime state1, theAlwaysP) m-    doit topology--    let state2 = Network-            { nTime    = next time1-            , nOutputs = OB.inserts outputs1 os-            , nAlwaysP = Just theAlwaysP-            }-    return (a,state2)--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}--- | Simple interpreter for pulse/latch networks.------ Mainly useful for testing functionality------ Note: The result is not computed lazily, for similar reasons--- that the 'sequence' function does not compute its result lazily.-interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b]-interpret f xs = do-    o   <- newIORef Nothing-    let network = do-            (pin, sin) <- liftBuild $ newInput-            pmid       <- f pin-            pout       <- liftBuild $ mapP return pmid-            liftBuild $ addHandler pout (writeIORef o . Just)-            return sin--    -- compile initial network-    (sin, state) <- compile network emptyNetwork--    let go Nothing  s1 = return (Nothing,s1)-        go (Just a) s1 = do-            (reactimate,s2) <- sin a s1-            reactimate              -- write output-            ma <- readIORef o       -- read output-            writeIORef o Nothing-            return (ma,s2)--    mapAccumM go state xs         -- run several steps---- | Execute an FRP network with a sequence of inputs.--- Make sure that outputs are evaluated, but don't display their values.------ Mainly useful for testing whether there are space leaks.-runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()-runSpaceProfile f xs = do-    let g = do-        (p1, fire) <- liftBuild $ newInput-        p2 <- f p1-        p3 <- mapP return p2                -- wrap into Future-        addHandler p3 (\b -> void $ evaluate b)-        return fire-    (step,network) <- compile g emptyNetwork--    let fire x s1 = do-            (outputs, s2) <- step x s1-            outputs                     -- don't forget to execute outputs-            return ((), s2)--    mapAccumM_ fire network xs---- | 'mapAccum' for a monad.-mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]-mapAccumM _ _  []     = return []-mapAccumM f s0 (x:xs) = do-    (b,s1) <- f x s0-    bs     <- mapAccumM f s1 xs-    return (b:bs)---- | Strict 'mapAccum' for a monad. Discards results.-mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()-mapAccumM_ _ _   []     = return ()-mapAccumM_ f !s0 (x:xs) = do-    (_,s1) <- f x s0-    mapAccumM_ f s1 xs
− src/Reactive/Banana/Prim/Dependencies.hs 
@@ -1,108 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}-module Reactive.Banana.Prim.Dependencies (-    -- | Utilities for operating on node dependencies.-    addChild, changeParent, buildDependencies,-    ) where--import Control.Monad-import Data.Functor-import Data.Monoid-import System.Mem.Weak--import qualified Reactive.Banana.Prim.Graph as Graph-import           Reactive.Banana.Prim.Types-import           Reactive.Banana.Prim.Util--{------------------------------------------------------------------------------    Accumulate dependency information for nodes-------------------------------------------------------------------------------}--- | Add a new child node to a parent node.-addChild :: SomeNode -> SomeNode -> DependencyBuilder-addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty)---- | Assign a new parent to a child node.--- INVARIANT: The child may have only one parent node.-changeParent :: Pulse a -> Pulse b -> DependencyBuilder-changeParent child parent = (mempty, [(P child, P parent)])---- | Execute the information in the dependency builder--- to change network topology.-buildDependencies :: DependencyBuilder -> IO ()-buildDependencies (Endo f, parents) = do-    sequence_ [x `doAddChild` y | x <- Graph.listParents gr, y <- Graph.getChildren gr x]-    sequence_ [x `doChangeParent` y | (P x, P y) <- parents]-    where-    gr :: Graph.Graph SomeNode-    gr = f Graph.emptyGraph--{------------------------------------------------------------------------------    Set dependencies of individual notes-------------------------------------------------------------------------------}--- | Add a child node to the children of a parent 'Pulse'.-connectChild-    :: Pulse a  -- ^ Parent node whose '_childP' field is to be updated.-    -> SomeNode -- ^ Child node to add.-    -> IO (Weak SomeNode)-                -- ^ Weak reference with the child as key and the parent as value.-connectChild parent child = do-    w <- mkWeakNodeValue child child-    modify' parent $ update childrenP (w:)-    mkWeakNodeValue child (P parent)        -- child keeps parent alive---- | Add a child node to a parent node and update evaluation order.-doAddChild :: SomeNode -> SomeNode -> IO ()-doAddChild (P parent) (P child) = do-    level1 <- _levelP <$> readRef child-    level2 <- _levelP <$> readRef parent-    let level = level1 `max` (level2 + 1)-    w <- parent `connectChild` (P child)-    modify' child $ set levelP level . update parentsP (w:)-doAddChild (P parent) node = void $ parent `connectChild` node---- | Remove a node from its parents and all parents from this node.-removeParents :: Pulse a -> IO ()-removeParents child = do-    c@Pulse{_parentsP} <- readRef child-    -- delete this child (and dead children) from all parent nodes-    forM_ _parentsP $ \w -> do-        Just (P parent) <- deRefWeak w  -- get parent node-        finalize w                      -- severe connection in garbage collector-        let isGoodChild w = not . maybe True (== P child) <$> deRefWeak w-        new <- filterM isGoodChild . _childrenP =<< readRef parent-        modify' parent $ set childrenP new-    -- replace parents by empty list-    put child $ c{_parentsP = []}---- | Set the parent of a pulse to a different pulse.-doChangeParent :: Pulse a -> Pulse b -> IO ()-doChangeParent child parent = do-    -- remove all previous parents and connect to new parent-    removeParents child-    w <- parent `connectChild` (P child)-    modify' child $ update parentsP (w:)--    -- calculate level difference between parent and node-    levelParent <- _levelP <$> readRef parent-    levelChild  <- _levelP <$> readRef child-    let d = levelParent - levelChild + 1-    -- level parent - d = level child - 1--    -- lower all parents of the node if the parent was higher than the node-    when (d > 0) $ do-        parents <- Graph.dfs (P parent) getParents-        forM_ parents $ \(P node) -> do-            modify' node $ update levelP (subtract d)--{------------------------------------------------------------------------------    Helper functions-------------------------------------------------------------------------------}-getChildren :: SomeNode -> IO [SomeNode]-getChildren (P p) = deRefWeaks =<< fmap _childrenP (readRef p)-getChildren _     = return []--getParents :: SomeNode -> IO [SomeNode]-getParents (P p) = deRefWeaks =<< fmap _parentsP (readRef p)-getParents _     = return []
− src/Reactive/Banana/Prim/Evaluation.hs 
@@ -1,124 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, BangPatterns #-}-module Reactive.Banana.Prim.Evaluation (-    step-    ) where--import qualified Control.Exception                  as Strict (evaluate)-import           Control.Monad                                (foldM)-import           Control.Monad                                (join)-import           Control.Monad.IO.Class-import qualified Control.Monad.Trans.RWSIO          as RWS-import qualified Control.Monad.Trans.ReaderWriterIO as RW-import           Data.Functor-import           Data.Maybe-import qualified Data.PQueue.Prio.Min               as Q-import qualified Data.Vault.Lazy                    as Lazy-import           System.Mem.Weak--import qualified Reactive.Banana.Prim.OrderedBag as OB-import           Reactive.Banana.Prim.Plumbing-import           Reactive.Banana.Prim.Types-import           Reactive.Banana.Prim.Util--type Queue = Q.MinPQueue Level--{------------------------------------------------------------------------------    Evaluation step-------------------------------------------------------------------------------}--- | Evaluate all the pulses in the graph,--- Rebuild the graph as necessary and update the latch values.-step :: Inputs -> Step-step (inputs,pulses)-        Network{ nTime = time1-        , nOutputs = outputs1-        , nAlwaysP = Just alwaysP   -- we assume that this has been built already-        }-    = {-# SCC step #-} do--    -- evaluate pulses-    ((_, (latchUpdates, outputs)), topologyUpdates, os)-            <- runBuildIO (time1, alwaysP)-            $  runEvalP pulses-            $  evaluatePulses inputs--    doit latchUpdates                           -- update latch values from pulses-    doit topologyUpdates                        -- rearrange graph topology-    let actions :: [(Output, EvalO)]-        actions = OB.inOrder outputs outputs1   -- EvalO actions in proper order--        state2 :: Network-        state2  = Network-            { nTime    = next time1-            , nOutputs = OB.inserts outputs1 os-            , nAlwaysP = Just alwaysP-            }-    return (runEvalOs $ map snd actions, state2)--runEvalOs :: [EvalO] -> IO ()-runEvalOs = sequence_ . map join--{------------------------------------------------------------------------------    Traversal in dependency order-------------------------------------------------------------------------------}--- | Update all pulses in the graph, starting from a given set of nodes-evaluatePulses :: [SomeNode] -> EvalP ()-evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty-    where-    go :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> Queue SomeNode -> IO ()-    go r q = {-# SCC go #-}-        case ({-# SCC minView #-} Q.minView q) of-            Nothing         -> return ()-            Just (node, q)  -> do-                children <- unwrapEvalP r (evaluateNode node)-                q        <- insertNodes r children q-                go r q---- | Recalculate a given node and return all children nodes--- that need to evaluated subsequently.-evaluateNode :: SomeNode -> EvalP [SomeNode]-evaluateNode (P p) = {-# SCC evaluateNodeP #-} do-    Pulse{..} <- readRef p-    ma        <- _evalP-    writePulseP _keyP ma-    case ma of-        Nothing -> return []-        Just _  -> liftIO $ deRefWeaks _childrenP-evaluateNode (L lw) = {-# SCC evaluateNodeL #-} do-    time           <- askTime-    LatchWrite{..} <- readRef lw-    mlatch         <- liftIO $ deRefWeak _latchLW -- retrieve destination latch-    case mlatch of-        Nothing    -> return ()-        Just latch -> do-            a <- _evalLW                    -- calculate new latch value-            -- liftIO $ Strict.evaluate a      -- see Note [LatchStrictness]-            rememberLatchUpdate $           -- schedule value to be set later-                modify' latch $ \l ->-                    a `seq` l { _seenL = time, _valueL = a }-    return []-evaluateNode (O o) = {-# SCC evaluateNodeO #-} do-    debug "evaluateNode O"-    Output{..} <- readRef o-    m          <- _evalO                    -- calculate output action-    rememberOutput $ (o,m)-    return []---- | Insert nodes into the queue-insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go-    where-    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-    go []              q = return q-    go (node@(P p):xs) q = do-        Pulse{..} <- readRef p-        if time <= _seenP-            then go xs q        -- pulse has already been put into the queue once-            else do             -- pulse needs to be scheduled for evaluation-                put p $! (let p = Pulse{..} in p { _seenP = time })-                go xs (Q.insert _levelP node q)-    go (node:xs)      q = go xs (Q.insert ground node q)-            -- O and L nodes have only one parent, so-            -- we can insert them at an arbitrary level
− src/Reactive/Banana/Prim/Graph.hs 
@@ -1,102 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Implementation of graph-related functionality-------------------------------------------------------------------------------}-{-# language ScopedTypeVariables#-}--module Reactive.Banana.Prim.Graph-  ( Graph-  , emptyGraph-  , insertEdge-  , getChildren-  , listParents-  , dfs-  ) where--import           Control.Monad-import           Data.Functor.Identity-import qualified Data.HashMap.Strict   as Map-import qualified Data.HashSet          as Set-import           Data.Hashable-import           Data.Maybe--{------------------------------------------------------------------------------    Graphs and topological sorting-------------------------------------------------------------------------------}-data Graph a = Graph-    { -- | The mapping from each node to the set of nodes reachable by an out-edge. If a node has no out-edges, it is-      -- not a member of this map.-      ---      -- Invariant: the values are non-empty lists.-      children :: Map.HashMap a [a]-      -- | The Mapping from each node to the set of nodes reachable by an in-edge. If a node has no in-edges, it is not-      -- a member of this map.-      ---      -- Invariant: the values are non-empty lists.-    , parents  :: Map.HashMap a [a]-      -- | The set of nodes.-      ---      -- Invariant: equals (key children `union` keys parents)-    , nodes    :: Set.HashSet a-    }---- | The graph with no edges and no nodes.-emptyGraph :: Graph a-emptyGraph = Graph Map.empty Map.empty Set.empty---- | Insert an edge from the first node to the second node into the graph.-insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a-insertEdge (x,y) gr = gr-    { children = Map.insertWith (\new old -> new ++ old) x [y] (children gr)-    , parents  = Map.insertWith (\new old -> new ++ old) y [x] (parents  gr)-    , nodes    = Set.insert x $ Set.insert y $ nodes gr-    }---- | Get all immediate children of a node in a graph.-getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a]-getChildren gr x = maybe [] id . Map.lookup x . children $ gr---- | Get all immediate parents of a node in a graph.-getParents :: (Eq a, Hashable a) => Graph a -> a -> [a]-getParents gr x = maybe [] id . Map.lookup x . parents $ gr---- | List all nodes such that each parent is listed before all of its children.-listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a]-listParents gr = list-    where-    -- all nodes without parents-    ancestors :: [a]-    -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges.-    ancestors    = [x | x <- Map.keys (children gr), not (hasParents x)]-    hasParents x = Map.member x (parents gr)-    -- all nodes in topological order "parents before children"-    list :: [a]-    list = runIdentity $ dfs' ancestors (Identity . getChildren gr)--{------------------------------------------------------------------------------    Graph traversal-------------------------------------------------------------------------------}--- | Graph represented as map of successors.-type GraphM m a = a -> m [a]---- | Depth-first search. List all transitive successors of a node.--- A node is listed *before* all its successors have been listed.-dfs :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]-dfs x = dfs' [x]---- | Depth-first serach, refined version.--- INVARIANT: None of the nodes in the initial list have a predecessor.-dfs' :: forall a m. (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]-dfs' xs succs = liftM fst $ go xs [] Set.empty-    where-    go :: [a] -> [a] -> Set.HashSet a -> m ([a], Set.HashSet a)-    go []     ys seen            = return (ys, seen)    -- all nodes seen-    go (x:xs) ys seen-        | x `Set.member` seen    = go xs ys seen-        | otherwise              = do-            xs' <- succs x-            -- visit all children-            (ys', seen') <- go xs' ys (Set.insert x seen)-            -- list this node as all successors have been seen-            go xs (x:ys') seen'
+ 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,56 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Reactive.Banana.Prim.IO where--import           Control.Monad.IO.Class-import           Data.Functor-import           Data.IORef-import qualified Data.Vault.Lazy        as Lazy--import Reactive.Banana.Prim.Combinators (mapP)-import Reactive.Banana.Prim.Evaluation  (step)-import Reactive.Banana.Prim.Plumbing-import Reactive.Banana.Prim.Types-import Reactive.Banana.Prim.Util--debug s = id--{------------------------------------------------------------------------------    Primitives connecting to the outside world-------------------------------------------------------------------------------}--- | Create a new pulse in the network and a function to trigger it.------ Together with 'addHandler', this function can be used to operate with--- pulses as with standard callback-based events.-newInput :: forall a. Build (Pulse a, a -> Step)-newInput = mdo-    always <- alwaysP-    key    <- liftIO $ Lazy.newKey-    pulse  <- liftIO $ newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = readPulseP pulse    -- get its own value-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = "newInput"-        }-    -- Also add the  alwaysP  pulse to the inputs.-    let run :: a -> Step-        run a = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty)-    return (pulse, run)---- | Register a handler to be executed whenever a pulse occurs.------ The pulse may refer to future latch values.-addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build ()-addHandler p1 f = do-    p2 <- mapP (fmap f) p1-    addOutput p2---- | Read the value of a 'Latch' at a particular moment in time.-readLatch :: Latch a -> Build a-readLatch = readLatchB
+ 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/OrderedBag.hs 
@@ -1,43 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Implementation of a bag whose elements are ordered by arrival time.-------------------------------------------------------------------------------}-{-# LANGUAGE TupleSections #-}-module Reactive.Banana.Prim.OrderedBag where--import           Data.Functor-import qualified Data.HashMap.Strict as Map-import           Data.Hashable-import           Data.List  hiding (insert)-import           Data.Maybe-import           Data.Ord--{------------------------------------------------------------------------------    Ordered Bag-------------------------------------------------------------------------------}-type Position = Integer--data OrderedBag a = OB !(Map.HashMap a Position) !Position--empty :: OrderedBag a-empty = OB Map.empty 0---- | Add an element to an ordered bag after all the others.--- Does nothing if the element is already in the bag.-insert :: (Eq a, Hashable a) => OrderedBag a -> a -> OrderedBag a-insert (OB xs n) x = OB (Map.insertWith (\new old -> old) x n xs) (n+1)---- | Add a sequence of elements to an ordered bag.------ The ordering is left-to-right. For example, the head of the sequence--- comes after all elements in the bag,--- but before the other elements in the sequence.-inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a-inserts = foldl' insert---- | Reorder a list of elements to appear as they were inserted into the bag.--- Remove any elements from the list that do not appear in the bag.-inOrder :: (Eq a, Hashable a) => [(a,b)] -> OrderedBag a -> [(a,b)]-inOrder xs (OB bag _) = map snd $ sortBy (comparing fst) $-    mapMaybe (\x -> (,x) <$> Map.lookup (fst x) bag) xs
− src/Reactive/Banana/Prim/Plumbing.hs 
@@ -1,254 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, RecursiveDo, BangPatterns, ScopedTypeVariables #-}-module Reactive.Banana.Prim.Plumbing where--import           Control.Monad                                (join)-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import qualified Control.Monad.Trans.RWSIO          as RWS-import qualified Control.Monad.Trans.Reader         as Reader-import qualified Control.Monad.Trans.ReaderWriterIO as RW-import           Data.Function                                (on)-import           Data.Functor-import           Data.IORef-import           Data.List                                    (sortBy)-import           Data.Monoid-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe--import qualified Reactive.Banana.Prim.Dependencies as Deps-import           Reactive.Banana.Prim.Types-import           Reactive.Banana.Prim.Util--{------------------------------------------------------------------------------    Build primitive pulses and latches-------------------------------------------------------------------------------}--- | Make 'Pulse' from evaluation function-newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)-newPulse name eval = liftIO $ do-    key <- Lazy.newKey-    newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = eval-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = name-        }--{--* Note [PulseCreation]--We assume that we do not have to calculate a pulse occurrence-at the moment we create the pulse. Otherwise, we would have-to recalculate the dependencies *while* doing evaluation;-this is a recipe for desaster.---}---- | 'Pulse' that never fires.-neverP :: Build (Pulse a)-neverP = liftIO $ do-    key <- Lazy.newKey-    newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = return Nothing-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = "neverP"-        }---- | Return a 'Latch' that has a constant value-pureL :: a -> Latch a-pureL a = unsafePerformIO $ newRef $ Latch-    { _seenL  = beginning-    , _valueL = a-    , _evalL  = return a-    }---- | Make new 'Latch' that can be updated by a 'Pulse'-newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch a)-newLatch a = mdo-    latch <- liftIO $ newRef $ Latch-        { _seenL  = beginning-        , _valueL = a-        , _evalL  = do-            Latch {..} <- readRef latch-            RW.tell _seenL  -- indicate timestamp-            return _valueL  -- indicate value-        }-    let-        err        = error "incorrect Latch write"--        updateOn :: Pulse a -> Build ()-        updateOn p = do-            w  <- liftIO $ mkWeakRefValue latch latch-            lw <- liftIO $ newRef $ LatchWrite-                { _evalLW  = maybe err id <$> readPulseP p-                , _latchLW = w-                }-            -- writer is alive only as long as the latch is alive-            _  <- liftIO $ mkWeakRefValue latch lw-            (P p) `addChild` (L lw)--    return (updateOn, latch)---- | Make a new 'Latch' that caches a previous computation.-cachedLatch :: EvalL a -> Latch a-cachedLatch eval = unsafePerformIO $ mdo-    latch <- newRef $ Latch-        { _seenL  = agesAgo-        , _valueL = error "Undefined value of a cached latch."-        , _evalL  = do-            Latch{..} <- liftIO $ readRef latch-            -- calculate current value (lazy!) with timestamp-            (a,time)  <- RW.listen eval-            liftIO $ if time <= _seenL-                then return _valueL     -- return old value-                else do                 -- update value-                    let _seenL  = time-                    let _valueL = a-                    a `seq` put latch (Latch {..})-                    return a-        }-    return latch---- | Add a new output that depends on a 'Pulse'.------ TODO: Return function to unregister the output again.-addOutput :: Pulse EvalO -> Build ()-addOutput p = do-    o <- liftIO $ newRef $ Output-        { _evalO = maybe (return $ debug "nop") id <$> readPulseP p-        }-    (P p) `addChild` (O o)-    RW.tell $ BuildW (mempty, [o], mempty, mempty)--{------------------------------------------------------------------------------    Build monad-------------------------------------------------------------------------------}-runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])-runBuildIO i m = {-# SCC runBuild #-} do-        (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m-        doit $ liftIOLaters          -- execute late IOs-        return (a,Action $ Deps.buildDependencies topologyUpdates,os)-    where-    -- Recursively execute the  buildLater  calls.-    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)-    unfold w m = do-        (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i-        let w' = w <> BuildW (w1,w2,w3,mempty)-        w'' <- case later of-            Just m  -> snd <$> unfold w' m-            Nothing -> return w'-        return (a,w'')--buildLater :: Build () -> Build ()-buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)---- | Pretend to return a value right now,--- but do not actually calculate it until later.------ NOTE: Accessing the value before it's written leads to an error.------ FIXME: Is there a way to have the value calculate on demand?-buildLaterReadNow :: Build a -> Build a-buildLaterReadNow m = do-    ref <- liftIO $ newIORef $-        error "buildLaterReadNow: Trying to read before it is written."-    buildLater $ m >>= liftIO . writeIORef ref-    liftIO $ unsafeInterleaveIO $ readIORef ref--liftBuild :: Build a -> BuildIO a-liftBuild = id--getTimeB :: Build Time-getTimeB = (\(x,_) -> x) <$> RW.ask--alwaysP :: Build (Pulse ())-alwaysP = (\(_,x) -> x) <$> RW.ask--readLatchB :: Latch a -> Build a-readLatchB = liftIO . readLatchIO--dependOn :: Pulse child -> Pulse parent -> Build ()-dependOn child parent = (P parent) `addChild` (P child)--keepAlive :: Pulse child -> Pulse parent -> Build ()-keepAlive child parent = liftIO $ mkWeakRefValue child parent >> return ()--addChild :: SomeNode -> SomeNode -> Build ()-addChild parent child =-    RW.tell $ BuildW (Deps.addChild parent child, mempty, mempty, mempty)--changeParent :: Pulse child -> Pulse parent -> Build ()-changeParent node parent =-    RW.tell $ BuildW (Deps.changeParent node parent, mempty, mempty, mempty)--liftIOLater :: IO () -> Build ()-liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty)--{------------------------------------------------------------------------------    EvalL monad-------------------------------------------------------------------------------}--- | Evaluate a latch (-computation) at the latest time,--- but discard timestamp information.-readLatchIO :: Latch a -> IO a-readLatchIO latch = do-    Latch{..} <- readRef latch-    liftIO $ fst <$> RW.runReaderWriterIOT _evalL ()--getValueL :: Latch a -> EvalL a-getValueL latch = do-    Latch{..} <- readRef latch-    _evalL--{------------------------------------------------------------------------------    EvalP monad-------------------------------------------------------------------------------}-runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)-runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do-    (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1-    return ((a,w1), w2)--liftBuildP :: Build a -> EvalP a-liftBuildP m = RWS.rwsT $ \r2 s -> do-    (a,w2) <- RW.runReaderWriterIOT m r2-    return (a,s,(mempty,w2))--askTime :: EvalP Time-askTime = fst <$> RWS.ask--readPulseP :: Pulse a -> EvalP (Maybe a)-readPulseP p = do-    Pulse{..} <- readRef p-    join . Lazy.lookup _keyP <$> RWS.get--writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()-writePulseP key a = do-    s <- RWS.get-    RWS.put $ Lazy.insert key a s--readLatchP :: Latch a -> EvalP a-readLatchP = liftBuildP . readLatchB--readLatchFutureP :: Latch a -> EvalP (Future a)-readLatchFutureP = return . readLatchIO--rememberLatchUpdate :: IO () -> EvalP ()-rememberLatchUpdate x = RWS.tell ((Action x,mempty),mempty)--rememberOutput :: (Output, EvalO) -> EvalP ()-rememberOutput x = RWS.tell ((mempty,[x]),mempty)---- worker wrapper to break sharing and support better inlining-unwrapEvalP :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a-unwrapEvalP r m = RWS.run m r--wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a-wrapEvalP m = RWS.R m
− src/Reactive/Banana/Prim/Test.hs 
@@ -1,39 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Prim.Test where--import Control.Applicative-import Reactive.Banana.Prim--main = test_space1--{------------------------------------------------------------------------------    Functionality tests-------------------------------------------------------------------------------}-test_accumL1 :: Pulse Int -> BuildIO (Pulse Int)-test_accumL1 p1 = liftBuild $ do-    p2     <- mapP (+) p1-    (l1,_) <- accumL 0 p2-    let l2 =  mapL const l1-    p3     <- applyP l2 p1-    return p3--test_recursion1 :: Pulse () -> BuildIO (Pulse Int)-test_recursion1 p1 = liftBuild $ mdo-    p2      <- applyP l2 p1-    p3      <- mapP (const (+1)) p2-    ~(l1,_) <- accumL (0::Int) p3-    let l2  =  mapL const l1-    return p2---- test garbage collection--{------------------------------------------------------------------------------    Space leak tests-------------------------------------------------------------------------------}-test_space1 = runSpaceProfile test_accumL1    $ [1..2*10^4]-test_space2 = runSpaceProfile test_recursion1 $ () <$ [1..2*10^4]--
− src/Reactive/Banana/Prim/Types.hs 
@@ -1,237 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module Reactive.Banana.Prim.Types where--import           Control.Monad.Trans.RWSIO-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.ReaderWriterIO-import           Data.Functor-import           Data.Hashable-import           Data.Monoid (Monoid, mempty, mappend)-import           Data.Semigroup-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe-import           System.Mem.Weak--import Reactive.Banana.Prim.Graph            (Graph)-import Reactive.Banana.Prim.OrderedBag as OB (OrderedBag, empty)-import Reactive.Banana.Prim.Util--{------------------------------------------------------------------------------    Network-------------------------------------------------------------------------------}--- | A 'Network' represents the state of a pulse/latch network,-data Network = Network-    { nTime           :: !Time                 -- Current time.-    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.-    , nAlwaysP        :: !(Maybe (Pulse ()))   -- Pulse that always fires.-    }--type Inputs        = ([SomeNode], Lazy.Vault)-type EvalNetwork a = Network -> IO (a, Network)-type Step          = EvalNetwork (IO ())--emptyNetwork :: Network-emptyNetwork = Network-    { nTime    = next beginning-    , nOutputs = OB.empty-    , nAlwaysP = Nothing-    }--type Build  = ReaderWriterIOT BuildR BuildW IO-type BuildR = (Time, Pulse ())-    -- ( current time-    -- , pulse that always fires)-newtype BuildW = BuildW (DependencyBuilder, [Output], Action, Maybe (Build ()))-    -- reader : current timestamp-    -- writer : ( actions that change the network topology-    --          , outputs to be added to the network-    --          , late IO actions-    --          , late build actions-    --          )--instance Semigroup BuildW where-    BuildW x <> BuildW y = BuildW (x <> y)--instance Monoid BuildW where-    mempty  = BuildW mempty-    mappend = (<>)--type BuildIO = Build--type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)])--{------------------------------------------------------------------------------    Synonyms-------------------------------------------------------------------------------}--- | Priority used to determine evaluation order for pulses.-type Level = Int--ground :: Level-ground = 0---- | 'IO' actions as a monoid with respect to sequencing.-newtype Action = Action { doit :: IO () }-instance Semigroup Action where-    Action x <> Action y = Action (x >> y)-instance Monoid Action where-    mempty = Action $ return ()-    mappend = (<>)---- | Lens-like functionality.-data Lens s a = Lens (s -> a) (a -> s -> s)--set :: Lens s a -> a -> s -> s-set (Lens _   set)   = set--update :: Lens s a -> (a -> a) -> s -> s-update (Lens get set) f = \s -> set (f $ get s) s--{------------------------------------------------------------------------------    Pulse and Latch-------------------------------------------------------------------------------}-type Pulse  a = Ref (Pulse' a)-data Pulse' a = Pulse-    { _keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.-    , _seenP     :: !Time              -- See note [Timestamp].-    , _evalP     :: EvalP (Maybe a)    -- Calculate current value.-    , _childrenP :: [Weak SomeNode]    -- Weak references to child nodes.-    , _parentsP  :: [Weak SomeNode]    -- Weak reference to parent nodes.-    , _levelP    :: !Level             -- Priority in evaluation order.-    , _nameP     :: String             -- Name for debugging.-    }--instance Show (Pulse a) where-    show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p)--type Latch  a = Ref (Latch' a)-data Latch' a = Latch-    { _seenL  :: !Time               -- Timestamp for the current value.-    , _valueL :: a                   -- Current value.-    , _evalL  :: EvalL a             -- Recalculate current latch value.-    }-type LatchWrite = Ref LatchWrite'-data LatchWrite' = forall a. LatchWrite-    { _evalLW  :: EvalP a            -- Calculate value to write.-    , _latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.-    }--type Output  = Ref Output'-data Output' = Output-    { _evalO     :: EvalP EvalO-    }-instance Eq Output where (==) = equalRef--data SomeNode-    = forall a. P (Pulse a)-    | L LatchWrite-    | O Output--instance Hashable SomeNode where-    hashWithSalt s (P x) = hashWithSalt s x-    hashWithSalt s (L x) = hashWithSalt s x-    hashWithSalt s (O x) = hashWithSalt s x--instance Eq SomeNode where-    (P x) == (P y) = equalRef x y-    (L x) == (L y) = equalRef x y-    (O x) == (O y) = equalRef x y--{-# INLINE mkWeakNodeValue #-}-mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)-mkWeakNodeValue (P x) = mkWeakRefValue x-mkWeakNodeValue (L x) = mkWeakRefValue x-mkWeakNodeValue (O x) = mkWeakRefValue x---- Lenses for various parameters-seenP :: Lens (Pulse' a) Time-seenP = Lens _seenP  (\a s -> s { _seenP = a })--seenL :: Lens (Latch' a) Time-seenL = Lens _seenL  (\a s -> s { _seenL = a })--valueL :: Lens (Latch' a) a-valueL = Lens _valueL (\a s -> s { _valueL = a })--parentsP :: Lens (Pulse' a) [Weak SomeNode]-parentsP = Lens _parentsP (\a s -> s { _parentsP = a })--childrenP :: Lens (Pulse' a) [Weak SomeNode]-childrenP = Lens _childrenP (\a s -> s { _childrenP = a })--levelP :: Lens (Pulse' a) Int-levelP = Lens _levelP (\a s -> s { _levelP = a })---- | Evaluation monads.-type EvalPW   = (EvalLW, [(Output, EvalO)])-type EvalLW   = Action--type EvalO    = Future (IO ())-type Future   = IO---- Note: For efficiency reasons, we unroll the monad transformer stack.--- type EvalP = RWST () Lazy.Vault EvalPW Build-type EvalP    = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO-    -- writer : (latch updates, IO action)-    -- state  : current pulse values---- Computation with a timestamp that indicates the last time it was performed.-type EvalL    = ReaderWriterIOT () Time IO--{------------------------------------------------------------------------------    Show functions for debugging-------------------------------------------------------------------------------}-printNode :: SomeNode -> IO String-printNode (P p) = _nameP <$> readRef p-printNode (L l) = return "L"-printNode (O o) = return "O"--{------------------------------------------------------------------------------    Time monoid-------------------------------------------------------------------------------}--- | A timestamp local to this program run.------ Useful e.g. for controlling cache validity.-newtype Time = T Integer deriving (Eq, Ord, Show, Read)---- | Before the beginning of time. See Note [TimeStamp]-agesAgo :: Time-agesAgo = T (-1)--beginning :: Time-beginning = T 0--next :: Time -> Time-next (T n) = T (n+1)--instance Semigroup Time where-    T x <> T y = T (max x y)--instance Monoid Time where-    mappend = (<>)-    mempty  = beginning--{------------------------------------------------------------------------------    Notes-------------------------------------------------------------------------------}-{- Note [Timestamp]--The time stamp indicates how recent the current value is.--For Pulse:-During pulse evaluation, a time stamp equal to the current-time indicates that the pulse has already been evaluated in this phase.--For Latch:-The timestamp indicates the last time at which the latch has been written to.--    agesAgo   = The latch has never been written to.-    beginning = The latch has been written to before everything starts.--The second description is ensured by the fact that the network-writes timestamps that begin at time `next beginning`.---}
− src/Reactive/Banana/Prim/Util.hs 
@@ -1,61 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE MagicHash, UnboxedTuples #-}-module Reactive.Banana.Prim.Util where--import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Hashable-import           Data.IORef-import           Data.Maybe                    (catMaybes)-import           Data.Unique.Really-import qualified GHC.Base               as GHC-import qualified GHC.IORef              as GHC-import qualified GHC.STRef              as GHC-import qualified GHC.Weak               as GHC-import           System.Mem.Weak--debug :: MonadIO m => String -> m ()--- debug = liftIO . putStrLn-debug _ = return ()--nop :: Monad m => m ()-nop = return ()--{------------------------------------------------------------------------------    IORefs that can be hashed-------------------------------------------------------------------------------}-data Ref a = Ref !(IORef a) !Unique--instance Hashable (Ref a) where hashWithSalt s (Ref _ u) = hashWithSalt s u --equalRef :: Ref a -> Ref b -> Bool-equalRef (Ref _ a) (Ref _ b) = a == b--newRef :: MonadIO m => a -> m (Ref a)-newRef a = liftIO $ liftM2 Ref (newIORef a) newUnique--readRef :: MonadIO m => Ref a -> m a-readRef ~(Ref ref _) = liftIO $ readIORef ref--put :: MonadIO m => Ref a -> a -> m ()-put ~(Ref ref _) = liftIO . writeIORef ref---- | Strictly modify an 'IORef'.-modify' :: MonadIO m => Ref a -> (a -> a) -> m ()-modify' ~(Ref ref _) f = liftIO $ readIORef ref >>= \x -> writeIORef ref $! f x--{------------------------------------------------------------------------------    Weak pointers-------------------------------------------------------------------------------}-mkWeakIORefValue :: IORef a -> value -> IO (Weak value)-mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) val = GHC.IO $ \s ->-  case GHC.mkWeakNoFinalizer# r# val s of (# s1, w #) -> (# s1, GHC.Weak w #)--mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value)-mkWeakRefValue (Ref ref _) v = liftIO $ mkWeakIORefValue ref v---- | Dereference a list of weak pointers while discarding dead ones.-deRefWeaks :: [Weak v] -> IO [v]-deRefWeaks ws = {-# SCC deRefWeaks #-} fmap catMaybes $ mapM deRefWeak ws
− src/Reactive/Banana/Test.hs 
@@ -1,253 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana--    Test cases and examples-------------------------------------------------------------------------------}-{-# LANGUAGE FlexibleContexts, Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}--import Control.Arrow-import Control.Monad (when, join)--import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.HUnit (testCase)--import Test.HUnit (assert, Assertion)---- import Test.QuickCheck--- import Test.QuickCheck.Property--import Control.Applicative-import Reactive.Banana.Test.Plumbing---main = defaultMain-    [ testGroup "Simple"-        [ testModelMatch "id"      id-        , testModelMatch "never1"  never1-        , testModelMatch "fmap1"   fmap1-        , testModelMatch "filter1" filter1-        , testModelMatch "filter2" filter2-        , testModelMatchM "accumE1" accumE1-        ]-    , testGroup "Complex"-        [ testModelMatchM "counter"     counter-        , testModelMatch "double"      double-        , testModelMatch "sharing"     sharing-        , testModelMatch "mergeFilter" mergeFilter-        , testModelMatchM "recursive1A"  recursive1A-        , testModelMatchM "recursive1B"  recursive1B-        , testModelMatchM "recursive2"  recursive2-        , testModelMatchM "recursive3"  recursive3-        , testModelMatchM "recursive4a" recursive4a-        -- , testModelMatchM "recursive4b" recursive4b-        , testModelMatchM "accumBvsE"   accumBvsE-        ]-    , testGroup "Dynamic Event Switching"-        [ testModelMatch  "observeE_id"         observeE_id-        , testModelMatch  "observeE_stepper"    observeE_stepper-        , testModelMatchM "valueB_immediate"    valueB_immediate-        -- , testModelMatchM "valueB_recursive1" valueB_recursive1-        -- , testModelMatchM "valueB_recursive2" valueB_recursive2-        , testModelMatchM "dynamic_apply"       dynamic_apply-        , testModelMatchM "switchE1"            switchE1-        , testModelMatchM "switchB1"            switchB1-        , testModelMatchM "switchB2"            switchB2-        ]-    , testGroup "Regression tests"-        [ testModelMatchM "issue79" issue79-        ]-    -- TODO:-    --  * algebraic laws-    --  * larger examples-    --  * quickcheck-    ]--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}-matchesModel-    :: (Show b, Eq b)-    => (Event a -> Moment (Event b)) -> [a] -> IO Bool-matchesModel f xs = do-    bs1 <- return $ interpretModel f (singletons xs)-    bs2 <- interpretGraph f (singletons xs)-    -- bs3 <- interpretFrameworks f xs-    let bs = [bs1,bs2]-    let b = all (==bs1) bs-    when (not b) $ mapM_ print bs-    return b--singletons = map Just---- test whether model matches-testModelMatchM-    :: (Show b, Eq b)-    => String -> (Event Int -> Moment (Event b)) -> Test-testModelMatchM name f = testCase name $ assert $ matchesModel f [1..8::Int]-testModelMatch name f = testModelMatchM name (return . f)---- individual tests for debugging-testModel :: (Event Int -> Event b) -> [Maybe b]-testModel f = interpretModel (return . f) $ singletons [1..8::Int]-testGraph f = interpretGraph (return . f) $ singletons [1..8::Int]--testModelM f = interpretModel f $ singletons [1..8::Int]-testGraphM f = interpretGraph f $ singletons [1..8::Int]---{------------------------------------------------------------------------------    Tests-------------------------------------------------------------------------------}-never1 :: Event Int -> Event Int-never1    = const never-fmap1     = fmap (+1)--filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing)-filter1   = filterE (>= 3)-filter2   = filterE (>= 3) . fmap (subtract 1)-accumE1   = accumE 0 . ((+1) <$)--counter e = do-    bcounter <- accumB 0 $ fmap (\_ -> (+1)) e-    return $ applyE (pure const <*> bcounter) e--merge e1 e2 = mergeWith id id (++) (list e1) (list e2)-    where list = fmap (:[])--double e  = merge e e-sharing e = merge e1 e1-    where e1 = filterE (< 3) e--mergeFilter e1 = mergeWith id id (+) e2 e3-    where-    e3 = fmap (+1) $ filterE even e1-    e2 = fmap (+1) $ filterE odd  e1--recursive1A e1 = mdo-    let e2 = applyE ((+) <$> b) e1-    b <- stepperB 0 e2-    return e2-recursive1B e1 = mdo-    b <- stepperB 0 e2-    let e2 = applyE ((+) <$> b) e1-    return e2--recursive2 e1 = mdo-    b  <- fmap ((+) <$>) $ stepperB 0 e3-    let e2 = applyE b e1-    let e3 = applyE (id <$> b) e1   -- actually equal to e2-    return e2--type Dummy = Int---- Counter that can be decreased as long as it's >= 0 .-recursive3 :: Event Dummy -> Moment (Event Int)-recursive3 edec = mdo-    bcounter <- accumB 4 $ (subtract 1) <$ ecandecrease-    let ecandecrease = whenE ((>0) <$> bcounter) edec-    return $ applyE (const <$> bcounter) ecandecrease---- Recursive 4 is an example reported by Merijn Verstraaten---   https://github.com/HeinrichApfelmus/reactive-banana/issues/56--- Minimization:-recursive4a :: Event Int -> Moment (Event (Bool, Int))-recursive4a eInput = mdo-    focus       <- stepperB False $ fst <$> resultE-    let resultE = resultB <@ eInput-    let resultB = (,) <$> focus <*> pureB 0-    return $ resultB <@ eInput--{---- Full example:-recursive4b :: Event Int -> Event (Bool, Int)-recursive4b eInput = result <@ eInput-    where-    focus     = stepperB False $ fst <$> result <@ eInput-    interface = (,) <$> focus <*> cntrVal-    (cntrVal, focusChange) = counter eInput focus-    result    = stepperB id ((***id) <$> focusChange) <*> interface--    filterApply :: Behavior (a -> Bool) -> Event a -> Event a-    filterApply b e = filterJust $ sat <$> b <@> e-        where sat p x = if p x then Just x else Nothing--    counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool))-    counter input active = (result, not <$ eq)-        where-        result = accumB 0 $ (+) <$> neq-        eq     = filterApply ((==) <$> result) input-        neq    = filterApply ((/=) <$> result) input--}---- Test 'accumE' vs 'accumB'.-accumBvsE :: Event Dummy -> Moment (Event [Int])-accumBvsE e = mdo-    e1 <- accumE 0 ((+1) <$ e)--    b  <- accumB 0 ((+1) <$ e)-    let e2 = applyE (const <$> b) e--    return $ merge e1 e2--observeE_id = observeE . fmap return -- = id--observeE_stepper :: Event Int -> Event Int-observeE_stepper e = observeE $ (valueB =<< mb) <$ e-    where-    mb :: Moment (Behavior Int)-    mb = stepper 0 e--valueB_immediate e = do-    x <- valueB =<< stepper 0 e-    return $ x <$ e--{-- The following tests would need to use the  valueBLater  combinator--valueB_recursive1 e1 = mdo-    _ <- initialB b-    let b = stepper 0 e1-    return $ b <@ e1--valueB_recursive2 e1 = mdo-    x <- initialB b-    let bf = const x <$ stepper 0 e1-    let b  = stepper 0 $ (bf <*> b) <@ e1-    return $ b <@ e1--}--dynamic_apply e = do-    b <- stepper 0 e-    return $ observeE $ (valueB b) <$ e-    -- = stepper 0 e <@ e--switchE1 e = switchE (e <$ e)--switchB1 e = do-    b0 <- stepper 0 e-    b1 <- stepper 0 e-    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e-    return $ b <@ e--switchB2 e = do-    b0 <- stepper 0 $ filterE even e-    b1 <- stepper 1 $ filterE odd  e-    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e-    return $ b <@ e--{------------------------------------------------------------------------------    Regression tests-------------------------------------------------------------------------------}-issue79 :: Event Dummy -> Moment (Event String)-issue79 inputEvent = mdo-    let-        appliedEvent  = (\_ _ -> 1) <$> lastValue <@> inputEvent-        filteredEvent = filterE (const True) appliedEvent-        fmappedEvent  = fmap id (filteredEvent)-    lastValue <- stepper 1 $ fmappedEvent--    let outputEvent = mergeWith id id (++)-            (const "filtered event" <$> filteredEvent)-            (((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent)--    return $ outputEvent-
− src/Reactive/Banana/Test/Plumbing.hs 
@@ -1,106 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}--- * Synopsis--- | Merge model and implementation into a single type. Not pretty.--module Reactive.Banana.Test.Plumbing where--import Control.Applicative-import Control.Monad (liftM, ap)-import Control.Monad.Fix--import qualified Reactive.Banana.Model as X-import qualified Reactive.Banana.Internal.Combinators as Y--{------------------------------------------------------------------------------    Types as pairs-------------------------------------------------------------------------------}--data Event    a = E (X.Event    a) (Y.Event    a)-data Behavior a = B (X.Behavior a) (Y.Behavior a)-data Moment   a = M (X.Moment   a) (Y.Moment   a)---- pair extractions-fstE (E x _) = x; sndE (E _ y) = y-fstB (B x _) = x; sndB (B _ y) = y-fstM (M x _) = x; sndM (M _ y) = y---- partial embedding functions-ex x = E x undefined; ey y = E undefined y-bx x = B x undefined; by y = B undefined y-mx x = M x undefined; my y = M undefined y---- interpretation-interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]-interpretModel f = X.interpret (fmap fstE . fstM . f . ex)--interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey)--{------------------------------------------------------------------------------    Primitive combinators-------------------------------------------------------------------------------}-never                               = E X.never Y.never-filterJust (E x y)                  = E (X.filterJust x) (Y.filterJust y)-mergeWith f g h (E x1 y1) (E x2 y2) = E (X.mergeWith f g h x1 x2) (Y.mergeWith f g h y1 y2)-mapE f (E x y)                      = E (fmap f x) (Y.mapE f y)-applyE ~(B x1 y1) (E x2 y2)         = E (X.apply x1 x2) (Y.applyE y1 y2)--instance Functor Event where fmap = mapE--pureB a                         = B (pure a) (Y.pureB a)-applyB (B x1 y1) (B x2 y2)      = B (x1 <*> x2) (Y.applyB y1 y2)-mapB f (B x y)                  = B (fmap f x) (Y.mapB f y)--instance Functor     Behavior where fmap = mapB-instance Applicative Behavior where pure = pureB; (<*>) = applyB--instance Functor Moment where fmap = liftM-instance Applicative Moment where-    pure  = return-    (<*>) = ap-instance Monad Moment where-    return a = M (return a) (return a)-    ~(M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g)-instance MonadFix Moment where-    mfix f = M (mfix fx) (mfix fy)-        where-        fx a = let M x _ = f a in x-        fy a = let M _ y = f a in y---accumE   a ~(E x y) = M-    (fmap ex $ X.accumE a x)-    (fmap ey $ Y.accumE a y)-stepperB a ~(E x y) = M-    (fmap bx $ X.stepper  a x)-    (fmap by $ Y.stepperB a y)-stepper            = stepperB--valueB ~(B x y) = M (X.valueB x) (Y.valueB y)--observeE :: Event (Moment a) -> Event a-observeE (E x y) = E (X.observeE $ fmap fstM x) (Y.observeE $ Y.mapE sndM y)--switchE :: Event (Event a) -> Moment (Event a)-switchE (E x y) = M-    (fmap ex $ X.switchE $   fmap (fstE) x)-    (fmap ey $ Y.switchE $ Y.mapE (sndE) y)--switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)-switchB (B x y) (E xe ye) = M-    (fmap bx $ X.switchB x $   fmap (fstB) xe)-    (fmap by $ Y.switchB y $ Y.mapE (sndB) ye)--{------------------------------------------------------------------------------    Derived combinators-------------------------------------------------------------------------------}-accumB acc e1 = do-    e2 <- accumE acc e1-    stepperB acc e2-whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)--infixl 4 <@>, <@-b <@ e  = applyE (const <$> b) e-b <@> e = applyE b e
src/Reactive/Banana/Types.hs view
@@ -1,3 +1,5 @@+{-# language CPP #-}+ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}@@ -8,15 +10,30 @@     Future(..),     ) where -import Data.Semigroup import Control.Applicative-import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix import Data.String (IsString(..))+import Control.Monad.Trans.Accum (AccumT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) -import qualified Reactive.Banana.Internal.Combinators as Prim+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS (RWST)+import qualified Control.Monad.Trans.Writer.CPS as CPS (WriterT)+#endif +import qualified Reactive.Banana.Prim.High.Combinators as Prim+ {-----------------------------------------------------------------------------     Types ------------------------------------------------------------------------------}@@ -60,7 +77,7 @@ -- > mempty :: Event a -- > mempty = never instance Semigroup a => Monoid (Event a) where-    mempty  = E $ Prim.never+    mempty  = E Prim.never     mappend = (<>)  @@ -146,7 +163,6 @@ 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@@ -187,22 +203,47 @@  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-    return  = M . return     m >>= g = M $ unM m >>= unM . g instance Applicative Moment where     pure    = M . pure     f <*> a = M $ unM f <*> unM a instance MonadFix Moment where mfix f = M $ mfix (unM . f) +instance Semigroup a => Semigroup (Moment a) where+    (<>) = liftA2 (<>)+instance Monoid a => Monoid (Moment a) where+    mempty = pure mempty++ instance Functor MomentIO where fmap f = MIO . fmap f . unMIO instance Monad MomentIO where-    return  = MIO . return     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