reactive-banana 1.3.1.0 → 1.3.2.0

raw patch · 37 files changed

+2554/−1449 lines, 37 filesdep +QuickCheckdep +deepseqdep +stmdep −psqueuesdep ~basedep ~containersdep ~hashable

Dependencies added: QuickCheck, deepseq, stm, tasty-quickcheck

Dependencies removed: psqueues

Dependency ranges changed: base, containers, hashable, pqueue, these

Files

• CHANGELOG.md +9/−2
• reactive-banana.cabal +68/−26
• src/Control/Monad/Trans/RWSIO.hs +0/−4
• src/Control/Monad/Trans/ReaderWriterIO.hs +0/−4
• src/Reactive/Banana/Frameworks.hs +7/−1
• src/Reactive/Banana/Prim/High/Combinators.hs +8/−3
• src/Reactive/Banana/Prim/Low/Compile.hs +0/−110
• src/Reactive/Banana/Prim/Low/Dependencies.hs +0/−119
• src/Reactive/Banana/Prim/Low/Evaluation.hs +0/−120
• src/Reactive/Banana/Prim/Low/Graph.hs +279/−81
• src/Reactive/Banana/Prim/Low/GraphGC.hs +223/−0
• src/Reactive/Banana/Prim/Low/GraphTraversal.hs +41/−0
• src/Reactive/Banana/Prim/Low/IO.hs +0/−55
• src/Reactive/Banana/Prim/Low/Plumbing.hs +0/−250
• src/Reactive/Banana/Prim/Low/Ref.hs +149/−0
• src/Reactive/Banana/Prim/Low/Types.hs +0/−227
• src/Reactive/Banana/Prim/Low/Util.hs +0/−63
• src/Reactive/Banana/Prim/Mid.hs +10/−7
• src/Reactive/Banana/Prim/Mid/Combinators.hs +27/−19
• src/Reactive/Banana/Prim/Mid/Compile.hs +119/−0
• src/Reactive/Banana/Prim/Mid/Evaluation.hs +125/−0
• src/Reactive/Banana/Prim/Mid/IO.hs +55/−0
• src/Reactive/Banana/Prim/Mid/Plumbing.hs +259/−0
• src/Reactive/Banana/Prim/Mid/Test.hs +1/−1
• src/Reactive/Banana/Prim/Mid/Types.hs +218/−0
• src/Reactive/Banana/Types.hs +0/−3
• test/Reactive/Banana/Test/High/Combinators.hs +255/−0
• test/Reactive/Banana/Test/High/Plumbing.hs +104/−0
• test/Reactive/Banana/Test/High/Space.hs +98/−0
• test/Reactive/Banana/Test/Low/Gen.hs +93/−0
• test/Reactive/Banana/Test/Low/Graph.hs +93/−0
• test/Reactive/Banana/Test/Low/GraphGC.hs +129/−0
• test/Reactive/Banana/Test/Mid/Space.hs +122/−0
• test/reactive-banana-tests.hs +27/−0
• test/space.hs +35/−0
• tests/Main.hs +0/−248
• tests/Plumbing.hs +0/−106

@@ -1,8 +1,16 @@ Changelog for the `reactive-banana` package ------------------------------------------- -**Version 1.3.1.0** (2002-08-11)+**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][]@@ -54,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** 

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             1.3.1.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,7 +25,12 @@ Category:            FRP Cabal-version:       1.18 Build-type:          Simple-Tested-with:         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@@ -41,6 +46,7 @@     hs-source-dirs:     src      build-depends:      base >= 4.2 && < 5,+                        deepseq >= 1.4.3.0 && < 1.5,                         semigroups >= 0.13 && < 0.21,                         containers >= 0.5 && < 0.7,                         transformers >= 0.2 && < 0.7,@@ -48,6 +54,7 @@                         unordered-containers >= 0.2.1.0 && < 0.3,                         hashable >= 1.1 && < 1.5,                         pqueue >= 1.0 && < 1.5,+                        stm >= 2.5 && < 2.6,                         these >= 0.2 && < 1.2      exposed-modules:@@ -57,45 +64,80 @@                         Reactive.Banana.Frameworks,                         Reactive.Banana.Model,                         Reactive.Banana.Prim.Mid,-                        Reactive.Banana.Prim.High.Cached+                        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.Prim.Low.Compile,-                        Reactive.Banana.Prim.Low.Dependencies,-                        Reactive.Banana.Prim.Low.Evaluation,-                        Reactive.Banana.Prim.Low.Graph,-                        Reactive.Banana.Prim.Low.IO,                         Reactive.Banana.Prim.Low.OrderedBag,-                        Reactive.Banana.Prim.Low.Plumbing,-                        Reactive.Banana.Prim.Low.Types,-                        Reactive.Banana.Prim.Low.Util,+                        Reactive.Banana.Prim.Low.GraphTraversal,                         Reactive.Banana.Prim.Mid.Combinators,+                        Reactive.Banana.Prim.Mid.Compile,+                        Reactive.Banana.Prim.Mid.Evaluation,+                        Reactive.Banana.Prim.Mid.IO,+                        Reactive.Banana.Prim.Mid.Plumbing,                         Reactive.Banana.Prim.Mid.Test,+                        Reactive.Banana.Prim.Mid.Types,                         Reactive.Banana.Prim.High.Combinators,                         Reactive.Banana.Types-    +     ghc-options: -Wall -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-fields -Werror=partial-fields -Wno-name-shadowing -Test-Suite tests+Test-Suite unit     default-language:   Haskell98     type:               exitcode-stdio-1.0-    hs-source-dirs:     tests-    main-is:            Main.hs-    other-modules:      Plumbing-    build-depends:      base >= 4.2 && < 5,+    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,-                        reactive-banana, vault, containers,-                        semigroups, transformers,-                        unordered-containers, hashable, psqueues, pqueue, these+                        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, tasty-bench, reactive-banana, containers, random, tasty-  hs-source-dirs: benchmark-  main-is: Main.hs-  ghc-options:  "-with-rtsopts=-A32m"+  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"

@@ -26,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@@ -44,9 +43,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

@@ -25,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@@ -50,9 +49,6 @@  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

@@ -33,7 +33,7 @@     interpretFrameworks, newEvent, mapEventIO, newBehavior,      -- * Running event networks-    EventNetwork, actuate, pause,+    EventNetwork, actuate, pause, getSize,      ) where @@ -331,6 +331,12 @@ -- the current event has been processed completely. 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

@@ -45,12 +45,12 @@ -- | 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 } f = whenFlag actuated $ do+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@@ -58,11 +58,14 @@             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@@ -75,12 +78,14 @@ compile setup = do     actuated <- newIORef False                   -- flag to set running status     s        <- newEmptyMVar                     -- setup callback machinery+    size     <- newIORef 0 -    let eventNetwork = EventNetwork{ actuated, s }+    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 

@@ -1,110 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-module Reactive.Banana.Prim.Low.Compile where--import Control.Exception (evaluate)-import Data.Functor-import Data.IORef--import           Reactive.Banana.Prim.Mid.Combinators (mapP)-import           Reactive.Banana.Prim.Low.IO-import qualified Reactive.Banana.Prim.Low.OrderedBag  as OB-import           Reactive.Banana.Prim.Low.Plumbing-import           Reactive.Banana.Prim.Low.Types--{------------------------------------------------------------------------------   Compilation-------------------------------------------------------------------------------}--- | Change a 'Network' of pulses and latches by--- executing a 'BuildIO' action.-compile :: BuildIO a -> Network -> IO (a, Network)-compile m Network{nTime, nOutputs, nAlwaysP} = do-    (a, topology, os) <- runBuildIO (nTime, nAlwaysP) m-    doit topology--    let state2 = Network-            { nTime    = next nTime-            , nOutputs = OB.inserts nOutputs os-            , nAlwaysP-            }-    return (a,state2)--emptyNetwork :: IO Network-emptyNetwork = do-  (alwaysP, _, _) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())-  pure Network-    { nTime    = next beginning-    , nOutputs = OB.empty-    , nAlwaysP = alwaysP-    }--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}--- | Simple interpreter for pulse/latch networks.------ Mainly useful for testing functionality------ Note: The result is not computed lazily, for similar reasons--- that the 'sequence' function does not compute its result lazily.-interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b]-interpret f xs = do-    o   <- newIORef Nothing-    let network = do-            (pin, sin) <- liftBuild newInput-            pmid       <- f pin-            pout       <- liftBuild $ mapP return pmid-            liftBuild $ addHandler pout (writeIORef o . Just)-            return sin--    -- compile initial network-    (sin, state) <- compile network =<< emptyNetwork--    let go Nothing  s1 = return (Nothing,s1)-        go (Just a) s1 = do-            (reactimate,s2) <- sin a s1-            reactimate              -- write output-            ma <- readIORef o       -- read output-            writeIORef o Nothing-            return (ma,s2)--    mapAccumM go state xs         -- run several steps---- | Execute an FRP network with a sequence of inputs.--- Make sure that outputs are evaluated, but don't display their values.------ Mainly useful for testing whether there are space leaks.-runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()-runSpaceProfile f xs = do-    let g = do-        (p1, fire) <- liftBuild newInput-        p2 <- f p1-        p3 <- mapP return p2                -- wrap into Future-        addHandler p3 (void . evaluate)-        return fire-    (step,network) <- compile g =<< emptyNetwork--    let fire x s1 = do-            (outputs, s2) <- step x s1-            outputs                     -- don't forget to execute outputs-            return ((), s2)--    mapAccumM_ fire network xs---- | 'mapAccum' for a monad.-mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]-mapAccumM _ _  []     = return []-mapAccumM f s0 (x:xs) = do-    (b,s1) <- f x s0-    bs     <- mapAccumM f s1 xs-    return (b:bs)---- | Strict 'mapAccum' for a monad. Discards results.-mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()-mapAccumM_ _ _   []     = return ()-mapAccumM_ f !s0 (x:xs) = do-    (_,s1) <- f x s0-    mapAccumM_ f s1 xs

@@ -1,119 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE LambdaCase #-}-module Reactive.Banana.Prim.Low.Dependencies (-    -- | Utilities for operating on node dependencies.-    addChild, changeParent, buildDependencies,-    ) where--import           Control.Monad-import           Data.Monoid-import           System.Mem.Weak--import qualified Reactive.Banana.Prim.Low.Graph as Graph-import           Reactive.Banana.Prim.Low.Types-import           Reactive.Banana.Prim.Low.Util--{------------------------------------------------------------------------------    Accumulate dependency information for nodes-------------------------------------------------------------------------------}--- | Add a new child node to a parent node.-addChild :: SomeNode -> SomeNode -> DependencyBuilder-addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty)---- | Assign a new parent to a child node.--- INVARIANT: The child may have only one parent node.-changeParent :: Pulse a -> Pulse b -> DependencyBuilder-changeParent child parent = (mempty, [(P child, P parent)])---- | Execute the information in the dependency builder--- to change network topology.-buildDependencies :: DependencyBuilder -> IO ()-buildDependencies (Endo f, parents) = do-    sequence_ [x `doAddChild` y | x <- Graph.listParents gr, y <- Graph.getChildren gr x]-    sequence_ [x `doChangeParent` y | (P x, P y) <- parents]-    where-    gr :: Graph.Graph SomeNode-    gr = f Graph.emptyGraph--{------------------------------------------------------------------------------    Set dependencies of individual notes-------------------------------------------------------------------------------}--- | Add a child node to the children of a parent 'Pulse'.-connectChild-    :: Pulse a  -- ^ Parent node whose '_childP' field is to be updated.-    -> SomeNode -- ^ Child node to add.-    -> IO (Weak SomeNode)-                -- ^ Weak reference with the child as key and the parent as value.-connectChild parent child = do-    w <- mkWeakNodeValue child child-    modify' parent $ update childrenP (w:)-    mkWeakNodeValue child (P parent)        -- child keeps parent alive---- | Add a child node to a parent node and update evaluation order.-doAddChild :: SomeNode -> SomeNode -> IO ()-doAddChild (P parent) (P child) = do-    level1 <- _levelP <$> readRef child-    level2 <- _levelP <$> readRef parent-    let level = level1 `max` (level2 + 1)-    w <- parent `connectChild` P child-    modify' child $ set levelP level . update parentsP (w:)-doAddChild (P parent) node = void $ parent `connectChild` node-doAddChild (L _) _ = error "doAddChild: Cannot add children to LatchWrite"-doAddChild (O _) _ = error "doAddChild: Cannot add children to Output"---- | Remove a node from its parents and all parents from this node.-removeParents :: Pulse a -> IO ()-removeParents child = do-    c@Pulse{_parentsP} <- readRef child-    -- delete this child (and dead children) from all parent nodes-    forM_ _parentsP $ \w -> do-        Just (P parent) <- deRefWeak w  -- get parent node-        finalize w                      -- severe connection in garbage collector-        let isGoodChild w = deRefWeak w >>= \x ->-              case x of-                Just y | y /= P child -> return True-                _                     -> do-                  -- The old parent refers to this child. In this case we'll remove-                  -- this child from the parent, but we also need to finalize the-                  -- weak pointer that points to the child. We need to do this because-                  -- otherwise the weak pointer will stay alive (even though it's-                  -- unreachable) for as long as the child is alive-                  -- https://github.com/HeinrichApfelmus/reactive-banana/pull/256-                  finalize w-                  return False-        new <- filterM isGoodChild . _childrenP =<< readRef parent-        modify' parent $ set childrenP new-    -- replace parents by empty list-    put child $ c{_parentsP = []}---- | Set the parent of a pulse to a different pulse.-doChangeParent :: Pulse a -> Pulse b -> IO ()-doChangeParent child parent = do-    -- remove all previous parents and connect to new parent-    removeParents child-    w <- parent `connectChild` P child-    modify' child $ update parentsP (w:)--    -- calculate level difference between parent and node-    levelParent <- _levelP <$> readRef parent-    levelChild  <- _levelP <$> readRef child-    let d = levelParent - levelChild + 1-    -- level parent - d = level child - 1--    -- lower all parents of the node if the parent was higher than the node-    when (d > 0) $ do-        parents <- Graph.reversePostOrder (P parent) getParents-        forM_ parents $ \case-            P node -> modify' node $ update levelP (subtract d)-            L _    -> error "doChangeParent: Cannot change parent of LatchWrite"-            O _    -> error "doChangeParent: Cannot change parent of Output"--{------------------------------------------------------------------------------    Helper functions-------------------------------------------------------------------------------}-getParents :: SomeNode -> IO [SomeNode]-getParents (P p) = deRefWeaks . _parentsP =<< readRef p-getParents _     = return []

@@ -1,120 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-module Reactive.Banana.Prim.Low.Evaluation (-    step-    ) where--import Control.Monad ( join )-import           Control.Monad.IO.Class-import qualified Control.Monad.Trans.RWSIO          as RWS-import qualified Data.PQueue.Prio.Min               as Q-import qualified Data.Vault.Lazy                    as Lazy-import           System.Mem.Weak--import qualified Reactive.Banana.Prim.Low.OrderedBag as OB-import           Reactive.Banana.Prim.Low.Plumbing-import           Reactive.Banana.Prim.Low.Types-import           Reactive.Banana.Prim.Low.Util--type Queue = Q.MinPQueue Level--{------------------------------------------------------------------------------    Evaluation step-------------------------------------------------------------------------------}--- | Evaluate all the pulses in the graph,--- Rebuild the graph as necessary and update the latch values.-step :: Inputs -> Step-step (inputs,pulses)-        Network{ nTime = time1-        , nOutputs = outputs1-        , nAlwaysP = alwaysP-        }-    = do--    -- evaluate pulses-    ((_, (latchUpdates, outputs)), topologyUpdates, os)-            <- runBuildIO (time1, alwaysP)-            $  runEvalP pulses-            $  evaluatePulses inputs--    doit latchUpdates                           -- update latch values from pulses-    doit topologyUpdates                        -- rearrange graph topology-    let actions :: [(Output, EvalO)]-        actions = OB.inOrder outputs outputs1   -- EvalO actions in proper order--        state2 :: Network-        !state2 = Network-            { nTime    = next time1-            , nOutputs = OB.inserts outputs1 os-            , nAlwaysP = alwaysP-            }-    return (runEvalOs $ map snd actions, state2)--runEvalOs :: [EvalO] -> IO ()-runEvalOs = mapM_ join--{------------------------------------------------------------------------------    Traversal in dependency order-------------------------------------------------------------------------------}--- | Update all pulses in the graph, starting from a given set of nodes-evaluatePulses :: [SomeNode] -> EvalP ()-evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty-    where-    go :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> Queue SomeNode -> IO ()-    go r q =-        case ({-# SCC minView #-} Q.minView q) of-            Nothing         -> return ()-            Just (node, q)  -> do-                children <- unwrapEvalP r (evaluateNode node)-                q        <- insertNodes r children q-                go r q---- | Recalculate a given node and return all children nodes--- that need to evaluated subsequently.-evaluateNode :: SomeNode -> EvalP [SomeNode]-evaluateNode (P p) = {-# SCC evaluateNodeP #-} do-    Pulse{..} <- readRef p-    ma        <- _evalP-    writePulseP _keyP ma-    case ma of-        Nothing -> return []-        Just _  -> liftIO $ deRefWeaks _childrenP-evaluateNode (L lw) = {-# SCC evaluateNodeL #-} do-    time           <- askTime-    LatchWrite{..} <- readRef lw-    mlatch         <- liftIO $ deRefWeak _latchLW -- retrieve destination latch-    case mlatch of-        Nothing    -> return ()-        Just latch -> do-            a <- _evalLW                    -- calculate new latch value-            -- liftIO $ Strict.evaluate a      -- see Note [LatchStrictness]-            rememberLatchUpdate $           -- schedule value to be set later-                modify' latch $ \l ->-                    a `seq` l { _seenL = time, _valueL = a }-    return []-evaluateNode (O o) = {-# SCC evaluateNodeO #-} do-    debug "evaluateNode O"-    Output{..} <- readRef o-    m          <- _evalO                    -- calculate output action-    rememberOutput (o,m)-    return []---- | Insert nodes into the queue-insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-insertNodes (RWS.Tuple (time,_) _ _) = go-    where-    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)-    go []              q = return q-    go (node@(P p):xs) q = do-        Pulse{..} <- readRef p-        if time <= _seenP-            then go xs q        -- pulse has already been put into the queue once-            else do             -- pulse needs to be scheduled for evaluation-                put p $! (let p = Pulse{..} in p { _seenP = time })-                go xs $! Q.insert _levelP node q-    go (node:xs)      q = go xs $! Q.insert ground node q-            -- O and L nodes have only one parent, so-            -- we can insert them at an arbitrary level

@@ -1,102 +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 -    Implementation of graph-related functionality+    , 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 ------------------------------------------------------------------------------}-{-# language ScopedTypeVariables#-}+-- | 'Level's are used to keep track of the order of vertices —+-- Lower levels come first.+type Level = Int -module Reactive.Banana.Prim.Low.Graph-  ( Graph-  , emptyGraph-  , insertEdge-  , getChildren-  , getParents-  , listParents-  , reversePostOrder-  ) where+ground :: Level+ground = 0 -import           Data.Functor.Identity-import           Data.Hashable-import qualified Data.HashMap.Strict   as Map-import qualified Data.HashSet          as Set-import           Data.Maybe+{-----------------------------------------------------------------------------+    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+ {------------------------------------------------------------------------------    Graphs and topological sorting+    Insertion ------------------------------------------------------------------------------}-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+-- | 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 --- | The graph with no edges and no nodes.-emptyGraph :: Graph a-emptyGraph = Graph Map.empty Map.empty Set.empty+    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) --- | 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+-- 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     } --- | Get all immediate children of a node in a graph.-getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a]-getChildren gr x = fromMaybe [] . Map.lookup x . children $ gr+-- | 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} --- | Get all immediate parents of a node in a graph.-getParents :: (Eq a, Hashable a) => Graph a -> a -> [a]-getParents gr x = fromMaybe [] . Map.lookup x . parents $ gr+-- | 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+    } --- | List all nodes such that each parent is listed before all of its children.-listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a]-listParents gr = list-    where-    -- all nodes without parents-    ancestors :: [a]-    -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges.-    ancestors    = [x | x <- Map.keys (children gr), not (hasParents x)]-    hasParents x = Map.member x (parents gr)-    -- all nodes in topological order "parents before children"-    list = runIdentity $ reversePostOrder' ancestors (Identity . getChildren gr)+-- | 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+ {------------------------------------------------------------------------------    Graph traversal+    Topological sort ------------------------------------------------------------------------------}--- | Graph represented as map of immediate children.-type GraphM m a = a -> m [a]+-- | 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 ] --- | Computes the reverse post-order,--- listing all transitive children of a node.--- Each node is listed *before* all its children have been listed.-reversePostOrder :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]-reversePostOrder x = reversePostOrder' [x]+data Step = Next | Stop --- | Reverse post-order from multiple nodes.--- INVARIANT: For this to be a valid topological order,--- none of the nodes may have a parent.-reversePostOrder' :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]-reversePostOrder' xs children = fst <$> go xs [] Set.empty-    where-    go []     rpo visited        = return (rpo, visited)-    go (x:xs) rpo visited-        | x `Set.member` visited = go xs rpo visited-        | otherwise              = do-            xs' <- children x-            -- visit all children-            (rpo', visited') <- go xs' rpo (Set.insert x visited)-            -- prepend this node as all children have been visited-            go xs (x:rpo') visited'+-- | 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

@@ -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, ())

@@ -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'

@@ -1,55 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Reactive.Banana.Prim.Low.IO where--import           Control.Monad.IO.Class-import qualified Data.Vault.Lazy        as Lazy--import Reactive.Banana.Prim.Mid.Combinators (mapP)-import Reactive.Banana.Prim.Low.Evaluation  (step)-import Reactive.Banana.Prim.Low.Plumbing-import Reactive.Banana.Prim.Low.Types-import Reactive.Banana.Prim.Low.Util--debug :: String -> a -> a-debug _ = id--{------------------------------------------------------------------------------    Primitives connecting to the outside world-------------------------------------------------------------------------------}--- | Create a new pulse in the network and a function to trigger it.------ Together with 'addHandler', this function can be used to operate with--- pulses as with standard callback-based events.-newInput :: forall a. Build (Pulse a, a -> Step)-newInput = mdo-    always <- alwaysP-    key    <- liftIO Lazy.newKey-    pulse  <- liftIO $ newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = readPulseP pulse    -- get its own value-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = "newInput"-        }-    -- Also add the  alwaysP  pulse to the inputs.-    let run :: a -> Step-        run a = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty)-    return (pulse, run)---- | Register a handler to be executed whenever a pulse occurs.------ The pulse may refer to future latch values.-addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build ()-addHandler p1 f = do-    p2 <- mapP (fmap f) p1-    addOutput p2---- | Read the value of a 'Latch' at a particular moment in time.-readLatch :: Latch a -> Build a-readLatch = readLatchB

@@ -1,250 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecordWildCards, RecursiveDo, ScopedTypeVariables #-}-module Reactive.Banana.Prim.Low.Plumbing where--import           Control.Monad                                (join)-import           Control.Monad.IO.Class-import qualified Control.Monad.Trans.RWSIO          as RWS-import qualified Control.Monad.Trans.ReaderWriterIO as RW-import           Data.Functor-import           Data.IORef-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe--import qualified Reactive.Banana.Prim.Low.Dependencies as Deps-import           Reactive.Banana.Prim.Low.Types-import           Reactive.Banana.Prim.Low.Util-import Data.Maybe (fromMaybe)--{------------------------------------------------------------------------------    Build primitive pulses and latches-------------------------------------------------------------------------------}--- | Make 'Pulse' from evaluation function-newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)-newPulse name eval = liftIO $ do-    key <- Lazy.newKey-    newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = eval-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = name-        }--{--* Note [PulseCreation]--We assume that we do not have to calculate a pulse occurrence-at the moment we create the pulse. Otherwise, we would have-to recalculate the dependencies *while* doing evaluation;-this is a recipe for desaster.---}---- | 'Pulse' that never fires.-neverP :: Build (Pulse a)-neverP = liftIO $ do-    key <- Lazy.newKey-    newRef $ Pulse-        { _keyP      = key-        , _seenP     = agesAgo-        , _evalP     = return Nothing-        , _childrenP = []-        , _parentsP  = []-        , _levelP    = ground-        , _nameP     = "neverP"-        }---- | Return a 'Latch' that has a constant value-pureL :: a -> Latch a-pureL a = unsafePerformIO $ newRef $ Latch-    { _seenL  = beginning-    , _valueL = a-    , _evalL  = return a-    }---- | Make new 'Latch' that can be updated by a 'Pulse'-newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch a)-newLatch a = mdo-    latch <- liftIO $ newRef $ Latch-        { _seenL  = beginning-        , _valueL = a-        , _evalL  = do-            Latch {..} <- readRef latch-            RW.tell _seenL  -- indicate timestamp-            return _valueL  -- indicate value-        }-    let-        err        = error "incorrect Latch write"--        updateOn :: Pulse a -> Build ()-        updateOn p = do-            w  <- liftIO $ mkWeakRefValue latch latch-            lw <- liftIO $ newRef $ LatchWrite-                { _evalLW  = fromMaybe err <$> readPulseP p-                , _latchLW = w-                }-            -- writer is alive only as long as the latch is alive-            _  <- liftIO $ mkWeakRefValue latch lw-            P p `addChild` L lw--    return (updateOn, latch)---- | Make a new 'Latch' that caches a previous computation.-cachedLatch :: EvalL a -> Latch a-cachedLatch eval = unsafePerformIO $ mdo-    latch <- newRef $ Latch-        { _seenL  = agesAgo-        , _valueL = error "Undefined value of a cached latch."-        , _evalL  = do-            Latch{..} <- liftIO $ readRef latch-            -- calculate current value (lazy!) with timestamp-            (a,time)  <- RW.listen eval-            liftIO $ if time <= _seenL-                then return _valueL     -- return old value-                else do                 -- update value-                    let _seenL  = time-                    let _valueL = a-                    a `seq` put latch (Latch {..})-                    return a-        }-    return latch---- | Add a new output that depends on a 'Pulse'.------ TODO: Return function to unregister the output again.-addOutput :: Pulse EvalO -> Build ()-addOutput p = do-    o <- liftIO $ newRef $ Output-        { _evalO = fromMaybe (return $ debug "nop") <$> readPulseP p-        }-    P p `addChild` O o-    RW.tell $ BuildW (mempty, [o], mempty, mempty)--{------------------------------------------------------------------------------    Build monad-------------------------------------------------------------------------------}-runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])-runBuildIO i m = do-        (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m-        doit liftIOLaters          -- execute late IOs-        return (a,Action $ Deps.buildDependencies topologyUpdates,os)-    where-    -- Recursively execute the  buildLater  calls.-    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)-    unfold w m = do-        (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i-        let w' = w <> BuildW (w1,w2,w3,mempty)-        w'' <- case later of-            Just m  -> snd <$> unfold w' m-            Nothing -> return w'-        return (a,w'')--buildLater :: Build () -> Build ()-buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)---- | Pretend to return a value right now,--- but do not actually calculate it until later.------ NOTE: Accessing the value before it's written leads to an error.------ FIXME: Is there a way to have the value calculate on demand?-buildLaterReadNow :: Build a -> Build a-buildLaterReadNow m = do-    ref <- liftIO $ newIORef $-        error "buildLaterReadNow: Trying to read before it is written."-    buildLater $ m >>= liftIO . writeIORef ref-    liftIO $ unsafeInterleaveIO $ readIORef ref--liftBuild :: Build a -> BuildIO a-liftBuild = id--getTimeB :: Build Time-getTimeB = fst <$> RW.ask--alwaysP :: Build (Pulse ())-alwaysP = snd <$> RW.ask--readLatchB :: Latch a -> Build a-readLatchB = liftIO . readLatchIO--dependOn :: Pulse child -> Pulse parent -> Build ()-dependOn child parent = P parent `addChild` P child--keepAlive :: Pulse child -> Pulse parent -> Build ()-keepAlive child parent = liftIO $ void $ mkWeakRefValue child parent--addChild :: SomeNode -> SomeNode -> Build ()-addChild parent child =-    RW.tell $ BuildW (Deps.addChild parent child, mempty, mempty, mempty)--changeParent :: Pulse child -> Pulse parent -> Build ()-changeParent node parent =-    RW.tell $ BuildW (Deps.changeParent node parent, mempty, mempty, mempty)--liftIOLater :: IO () -> Build ()-liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty)--{------------------------------------------------------------------------------    EvalL monad-------------------------------------------------------------------------------}--- | Evaluate a latch (-computation) at the latest time,--- but discard timestamp information.-readLatchIO :: Latch a -> IO a-readLatchIO latch = do-    Latch{..} <- readRef latch-    liftIO $ fst <$> RW.runReaderWriterIOT _evalL ()--getValueL :: Latch a -> EvalL a-getValueL latch = do-    Latch{..} <- readRef latch-    _evalL--{------------------------------------------------------------------------------    EvalP monad-------------------------------------------------------------------------------}-runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)-runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do-    (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1-    return ((a,w1), w2)--liftBuildP :: Build a -> EvalP a-liftBuildP m = RWS.rwsT $ \r2 s -> do-    (a,w2) <- RW.runReaderWriterIOT m r2-    return (a,s,(mempty,w2))--askTime :: EvalP Time-askTime = fst <$> RWS.ask--readPulseP :: Pulse a -> EvalP (Maybe a)-readPulseP p = do-    Pulse{..} <- readRef p-    join . Lazy.lookup _keyP <$> RWS.get--writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()-writePulseP key a = do-    s <- RWS.get-    RWS.put $ Lazy.insert key a s--readLatchP :: Latch a -> EvalP a-readLatchP = liftBuildP . readLatchB--readLatchFutureP :: Latch a -> EvalP (Future a)-readLatchFutureP = return . readLatchIO--rememberLatchUpdate :: IO () -> EvalP ()-rememberLatchUpdate x = RWS.tell ((Action x,mempty),mempty)--rememberOutput :: (Output, EvalO) -> EvalP ()-rememberOutput x = RWS.tell ((mempty,[x]),mempty)---- worker wrapper to break sharing and support better inlining-unwrapEvalP :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a-unwrapEvalP r m = RWS.run m r--wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a-wrapEvalP m = RWS.R m

@@ -0,0 +1,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 #)

@@ -1,227 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-module Reactive.Banana.Prim.Low.Types where--import           Control.Monad.Trans.RWSIO-import           Control.Monad.Trans.ReaderWriterIO-import           Data.Hashable-import           Data.Semigroup-import qualified Data.Vault.Lazy                    as Lazy-import           System.IO.Unsafe-import           System.Mem.Weak--import Reactive.Banana.Prim.Low.Graph            (Graph)-import Reactive.Banana.Prim.Low.OrderedBag as OB (OrderedBag)-import Reactive.Banana.Prim.Low.Util--{------------------------------------------------------------------------------    Network-------------------------------------------------------------------------------}--- | A 'Network' represents the state of a pulse/latch network,-data Network = Network-    { nTime           :: !Time                 -- Current time.-    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.-    , nAlwaysP        :: !(Pulse ())   -- Pulse that always fires.-    }--type Inputs        = ([SomeNode], Lazy.Vault)-type EvalNetwork a = Network -> IO (a, Network)-type Step          = EvalNetwork (IO ())--type Build  = ReaderWriterIOT BuildR BuildW IO-type BuildR = (Time, Pulse ())-    -- ( current time-    -- , pulse that always fires)-newtype BuildW = BuildW (DependencyBuilder, [Output], Action, Maybe (Build ()))-    -- reader : current timestamp-    -- writer : ( actions that change the network topology-    --          , outputs to be added to the network-    --          , late IO actions-    --          , late build actions-    --          )--instance Semigroup BuildW where-    BuildW x <> BuildW y = BuildW (x <> y)--instance Monoid BuildW where-    mempty  = BuildW mempty-    mappend = (<>)--type BuildIO = Build--type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)])--{------------------------------------------------------------------------------    Synonyms-------------------------------------------------------------------------------}--- | Priority used to determine evaluation order for pulses.-type Level = Int--ground :: Level-ground = 0---- | 'IO' actions as a monoid with respect to sequencing.-newtype Action = Action { doit :: IO () }-instance Semigroup Action where-    Action x <> Action y = Action (x >> y)-instance Monoid Action where-    mempty = Action $ return ()-    mappend = (<>)---- | Lens-like functionality.-data Lens s a = Lens (s -> a) (a -> s -> s)--set :: Lens s a -> a -> s -> s-set (Lens _   set)   = set--update :: Lens s a -> (a -> a) -> s -> s-update (Lens get set) f = \s -> set (f $ get s) s--{------------------------------------------------------------------------------    Pulse and Latch-------------------------------------------------------------------------------}-type Pulse  a = Ref (Pulse' a)-data Pulse' a = Pulse-    { _keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.-    , _seenP     :: !Time              -- See note [Timestamp].-    , _evalP     :: EvalP (Maybe a)    -- Calculate current value.-    , _childrenP :: [Weak SomeNode]    -- Weak references to child nodes.-    , _parentsP  :: [Weak SomeNode]    -- Weak reference to parent nodes.-    , _levelP    :: !Level             -- Priority in evaluation order.-    , _nameP     :: String             -- Name for debugging.-    }--instance Show (Pulse a) where-    show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p)--type Latch  a = Ref (Latch' a)-data Latch' a = Latch-    { _seenL  :: !Time               -- Timestamp for the current value.-    , _valueL :: a                   -- Current value.-    , _evalL  :: EvalL a             -- Recalculate current latch value.-    }-type LatchWrite = Ref LatchWrite'-data LatchWrite' = forall a. LatchWrite-    { _evalLW  :: EvalP a            -- Calculate value to write.-    , _latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.-    }--type Output  = Ref Output'-data Output' = Output-    { _evalO     :: EvalP EvalO-    }--data SomeNode-    = forall a. P (Pulse a)-    | L LatchWrite-    | O Output--instance Hashable SomeNode where-    hashWithSalt s (P x) = hashWithSalt s x-    hashWithSalt s (L x) = hashWithSalt s x-    hashWithSalt s (O x) = hashWithSalt s x--instance Eq SomeNode where-    (P x) == (P y) = equalRef x y-    (L x) == (L y) = equalRef x y-    (O x) == (O y) = equalRef x y-    _     == _     = False--{-# INLINE mkWeakNodeValue #-}-mkWeakNodeValue :: SomeNode -> v -> IO (Weak v)-mkWeakNodeValue (P x) = mkWeakRefValue x-mkWeakNodeValue (L x) = mkWeakRefValue x-mkWeakNodeValue (O x) = mkWeakRefValue x---- Lenses for various parameters-seenP :: Lens (Pulse' a) Time-seenP = Lens _seenP  (\a s -> s { _seenP = a })--seenL :: Lens (Latch' a) Time-seenL = Lens _seenL  (\a s -> s { _seenL = a })--valueL :: Lens (Latch' a) a-valueL = Lens _valueL (\a s -> s { _valueL = a })--parentsP :: Lens (Pulse' a) [Weak SomeNode]-parentsP = Lens _parentsP (\a s -> s { _parentsP = a })--childrenP :: Lens (Pulse' a) [Weak SomeNode]-childrenP = Lens _childrenP (\a s -> s { _childrenP = a })--levelP :: Lens (Pulse' a) Int-levelP = Lens _levelP (\a s -> s { _levelP = a })---- | Evaluation monads.-type EvalPW   = (EvalLW, [(Output, EvalO)])-type EvalLW   = Action--type EvalO    = Future (IO ())-type Future   = IO---- Note: For efficiency reasons, we unroll the monad transformer stack.--- type EvalP = RWST () Lazy.Vault EvalPW Build-type EvalP    = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO-    -- writer : (latch updates, IO action)-    -- state  : current pulse values---- Computation with a timestamp that indicates the last time it was performed.-type EvalL    = ReaderWriterIOT () Time IO--{------------------------------------------------------------------------------    Show functions for debugging-------------------------------------------------------------------------------}-printNode :: SomeNode -> IO String-printNode (P p) = _nameP <$> readRef p-printNode (L _) = return "L"-printNode (O _) = return "O"--{------------------------------------------------------------------------------    Time monoid-------------------------------------------------------------------------------}--- | A timestamp local to this program run.------ Useful e.g. for controlling cache validity.-newtype Time = T Integer deriving (Eq, Ord, Show, Read)---- | Before the beginning of time. See Note [TimeStamp]-agesAgo :: Time-agesAgo = T (-1)--beginning :: Time-beginning = T 0--next :: Time -> Time-next (T n) = T (n+1)--instance Semigroup Time where-    T x <> T y = T (max x y)--instance Monoid Time where-    mappend = (<>)-    mempty  = beginning--{------------------------------------------------------------------------------    Notes-------------------------------------------------------------------------------}-{- Note [Timestamp]--The time stamp indicates how recent the current value is.--For Pulse:-During pulse evaluation, a time stamp equal to the current-time indicates that the pulse has already been evaluated in this phase.--For Latch:-The timestamp indicates the last time at which the latch has been written to.--    agesAgo   = The latch has never been written to.-    beginning = The latch has been written to before everything starts.--The second description is ensured by the fact that the network-writes timestamps that begin at time `next beginning`.---}

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

@@ -9,7 +9,7 @@     -- have a look at "Reactive.Banana" instead.      -- * Evaluation-    Step, Network, emptyNetwork,+    Step, EvalNetwork, Network, emptyNetwork, getSize,      -- * Build FRP networks     Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,@@ -33,20 +33,23 @@     pureL, mapL, applyL, accumL, applyP,      -- * Dynamic event switching-    switchL, executeP, switchP+    switchL, executeP, switchP,      -- * Notes     -- $recursion+    +    -- * Debugging+    printDot   ) where   import Control.Monad.IO.Class-import Reactive.Banana.Prim.Low.Compile-import Reactive.Banana.Prim.Low.IO-import Reactive.Banana.Prim.Low.Plumbing-    ( neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater )-import Reactive.Banana.Prim.Low.Types import Reactive.Banana.Prim.Mid.Combinators+import Reactive.Banana.Prim.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  {-----------------------------------------------------------------------------

@@ -1,20 +1,25 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-} {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-} module Reactive.Banana.Prim.Mid.Combinators where  import Control.Monad+    ( join ) import Control.Monad.IO.Class+    ( liftIO ) -import Reactive.Banana.Prim.Low.Plumbing+import Reactive.Banana.Prim.Mid.Plumbing     ( newPulse, newLatch, cachedLatch     , dependOn, keepAlive, changeParent     , getValueL     , readPulseP, readLatchP, readLatchFutureP, liftBuildP,     )-import qualified Reactive.Banana.Prim.Low.Plumbing (pureL)-import           Reactive.Banana.Prim.Low.Types    (Latch, Future, Pulse, Build, EvalP)+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@@ -85,7 +90,7 @@     return p  pureL :: a -> Latch a-pureL = Reactive.Banana.Prim.Low.Plumbing.pureL+pureL = Reactive.Banana.Prim.Mid.Plumbing.pureL  -- specialization of   mapL f = applyL (pureL f) mapL :: (a -> b) -> Latch a -> Latch b@@ -132,22 +137,25 @@     eval Nothing  = return Nothing  switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a)-switchP p pp = mdo+switchP p pp = do+    -- track the latest Pulse in a Latch     lp <- stepperL p pp-    let-        -- switch to a new parent++    -- 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  -> return ()-                Just new -> liftBuildP $ p2 `changeParent` new-            return Nothing-        -- fetch value from old parent-        eval = readPulseP =<< readLatchP lp+                Nothing  -> pure ()+                Just new -> liftBuildP $ pout `changeParent` new+            pure Nothing -    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())-    p1 `dependOn` pp-    p2 <- newPulse "switchP_out" eval-    p2 `dependOn` p-    p2 `keepAlive` p1-    return p2+    pin <- newPulse "switchP_in" switch :: Build (Pulse ())+    pin  `dependOn` pp+    +    pout `dependOn` p       -- initial dependency+    pout `keepAlive` pin    -- keep switches happening+    pure pout

@@ -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

@@ -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 }

@@ -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

@@ -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

@@ -1,7 +1,7 @@+{-# LANGUAGE RecursiveDo #-} {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.Mid.Test where  import Reactive.Banana.Prim.Mid

@@ -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`.++-}

@@ -163,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@@ -224,7 +223,6 @@ -- 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@@ -239,7 +237,6 @@  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

@@ -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+

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+        ]+    ]

@@ -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

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

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