diff -Nru haskell-reactive-banana-1.3.1.0/CHANGELOG.md haskell-reactive-banana-1.3.2.0/CHANGELOG.md --- haskell-reactive-banana-1.3.1.0/CHANGELOG.md 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/CHANGELOG.md 2001-09-09 01:46:40.000000000 +0000 @@ -1,7 +1,15 @@ 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][] @@ -55,7 +63,6 @@ [#212]: https://github.com/HeinrichApfelmus/reactive-banana/pull/212 [#220]: https://github.com/HeinrichApfelmus/reactive-banana/pull/219 - **version 1.2.1.0** * Add `Num`, `Floating`, `Fractional`, and `IsString` instances for `Behavior`. [#34][] diff -Nru haskell-reactive-banana-1.3.1.0/debian/changelog haskell-reactive-banana-1.3.2.0/debian/changelog --- haskell-reactive-banana-1.3.1.0/debian/changelog 2022-12-11 20:16:52.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/debian/changelog 2023-09-15 18:55:39.000000000 +0000 @@ -1,8 +1,18 @@ -haskell-reactive-banana (1.3.1.0-1build1) lunar; urgency=medium +haskell-reactive-banana (1.3.2.0-2) unstable; urgency=medium - * Rebuild against new GHC ABI. + * Patch for newer these. - -- Gianfranco Costamagna Sun, 11 Dec 2022 21:16:52 +0100 + -- Clint Adams Fri, 15 Sep 2023 14:55:39 -0400 + +haskell-reactive-banana (1.3.2.0-1) unstable; urgency=medium + + [ Ilias Tsitsimpis ] + * Declare compliance with Debian policy 4.6.2 + + [ Clint Adams ] + * New upstream release + + -- Clint Adams Wed, 13 Sep 2023 13:22:40 -0400 haskell-reactive-banana (1.3.1.0-1) unstable; urgency=medium diff -Nru haskell-reactive-banana-1.3.1.0/debian/control haskell-reactive-banana-1.3.2.0/debian/control --- haskell-reactive-banana-1.3.1.0/debian/control 2022-10-23 16:59:10.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/debian/control 2023-09-15 18:55:39.000000000 +0000 @@ -21,7 +21,7 @@ libghc-semigroups-dev (<< 0.21), libghc-semigroups-prof, libghc-these-dev (>= 0.2), - libghc-these-dev (<< 1.2), + libghc-these-dev (<< 1.3), libghc-these-prof, libghc-unordered-containers-dev (>= 0.2.1.0), libghc-unordered-containers-dev (<< 0.3), @@ -38,8 +38,8 @@ libghc-these-doc, libghc-unordered-containers-doc, libghc-vault-doc, -Standards-Version: 4.6.1 -Homepage: http://wiki.haskell.org/Reactive-banana +Standards-Version: 4.6.2 +Homepage: https://wiki.haskell.org/Reactive-banana Vcs-Browser: https://salsa.debian.org/haskell-team/DHG_packages/tree/master/p/haskell-reactive-banana Vcs-Git: https://salsa.debian.org/haskell-team/DHG_packages.git [p/haskell-reactive-banana] X-Description: Library for functional reactive programming (FRP) diff -Nru haskell-reactive-banana-1.3.1.0/debian/patches/newer-deps haskell-reactive-banana-1.3.2.0/debian/patches/newer-deps --- haskell-reactive-banana-1.3.1.0/debian/patches/newer-deps 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/debian/patches/newer-deps 2023-09-15 18:55:39.000000000 +0000 @@ -0,0 +1,11 @@ +--- a/reactive-banana.cabal ++++ b/reactive-banana.cabal +@@ -55,7 +55,7 @@ Library + hashable >= 1.1 && < 1.5, + pqueue >= 1.0 && < 1.5, + stm >= 2.5 && < 2.6, +- these >= 0.2 && < 1.2 ++ these >= 0.2 && < 1.3 + + exposed-modules: + Control.Event.Handler, diff -Nru haskell-reactive-banana-1.3.1.0/debian/patches/series haskell-reactive-banana-1.3.2.0/debian/patches/series --- haskell-reactive-banana-1.3.1.0/debian/patches/series 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/debian/patches/series 2023-09-15 18:55:39.000000000 +0000 @@ -0,0 +1 @@ +newer-deps diff -Nru haskell-reactive-banana-1.3.1.0/reactive-banana.cabal haskell-reactive-banana-1.3.2.0/reactive-banana.cabal --- haskell-reactive-banana-1.3.1.0/reactive-banana.cabal 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/reactive-banana.cabal 2001-09-09 01:46:40.000000000 +0000 @@ -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" diff -Nru haskell-reactive-banana-1.3.1.0/src/Control/Monad/Trans/RWSIO.hs haskell-reactive-banana-1.3.2.0/src/Control/Monad/Trans/RWSIO.hs --- haskell-reactive-banana-1.3.1.0/src/Control/Monad/Trans/RWSIO.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Control/Monad/Trans/RWSIO.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 @@ -45,9 +44,6 @@ fmapR :: Functor m => (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b fmapR f m = R $ \x -> fmap f (run m x) -returnR :: Monad m => a -> RWSIOT r w s m a -returnR a = R $ \_ -> return a - bindR :: Monad m => RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b bindR m k = R $ \x -> run m x >>= \a -> run (k a) x diff -Nru haskell-reactive-banana-1.3.1.0/src/Control/Monad/Trans/ReaderWriterIO.hs haskell-reactive-banana-1.3.2.0/src/Control/Monad/Trans/ReaderWriterIO.hs --- haskell-reactive-banana-1.3.1.0/src/Control/Monad/Trans/ReaderWriterIO.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Control/Monad/Trans/ReaderWriterIO.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 @@ -51,9 +50,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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Frameworks.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Frameworks.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Frameworks.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Frameworks.hs 2001-09-09 01:46:40.000000000 +0000 @@ -33,7 +33,7 @@ interpretFrameworks, newEvent, mapEventIO, newBehavior, -- * Running event networks - EventNetwork, actuate, pause, + EventNetwork, actuate, pause, getSize, ) where @@ -332,6 +332,12 @@ pause :: EventNetwork -> IO () pause = Prim.pause . unEN +-- | PROVISIONAL. +-- Measure of the number of events in the event network. +-- Useful for understanding space usage. +getSize :: EventNetwork -> IO Int +getSize = Prim.getSize . unEN + {----------------------------------------------------------------------------- Utilities ------------------------------------------------------------------------------} diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/High/Combinators.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/High/Combinators.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/High/Combinators.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/High/Combinators.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Compile.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Compile.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Compile.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Compile.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Dependencies.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Dependencies.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Dependencies.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Dependencies.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 [] diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Evaluation.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Evaluation.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Evaluation.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Evaluation.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Graph.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Graph.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Graph.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Graph.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 + + , 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 - Implementation of graph-related functionality +{----------------------------------------------------------------------------- + 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 - -import Data.Functor.Identity -import Data.Hashable -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Maybe - -{----------------------------------------------------------------------------- - Graphs and topological sorting -------------------------------------------------------------------------------} -data Graph a = Graph - { -- | The mapping from each node to the set of nodes reachable by an out-edge. If a node has no out-edges, it is - -- not a member of this map. - -- - -- Invariant: the values are non-empty lists. - children :: Map.HashMap a [a] - -- | The Mapping from each node to the set of nodes reachable by an in-edge. If a node has no in-edges, it is not - -- a member of this map. - -- - -- Invariant: the values are non-empty lists. - , parents :: Map.HashMap a [a] - -- | The set of nodes. - -- - -- Invariant: equals (key children `union` keys parents) - , nodes :: Set.HashSet a - } - --- | The graph with no edges and no nodes. -emptyGraph :: Graph a -emptyGraph = Graph Map.empty Map.empty Set.empty - --- | Insert an edge from the first node to the second node into the graph. -insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a -insertEdge (x,y) gr = gr - { children = Map.insertWith (\new old -> new ++ old) x [y] (children gr) - , parents = Map.insertWith (\new old -> new ++ old) y [x] (parents gr) - , nodes = Set.insert x $ Set.insert y $ nodes gr - } - --- | Get all immediate children of a node in a graph. -getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a] -getChildren gr x = fromMaybe [] . Map.lookup x . children $ gr - --- | Get all immediate parents of a node in a graph. -getParents :: (Eq a, Hashable a) => Graph a -> a -> [a] -getParents gr x = fromMaybe [] . Map.lookup x . parents $ gr - --- | List all nodes such that each parent is listed before all of its children. -listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a] -listParents gr = list - where - -- all nodes without parents - ancestors :: [a] - -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges. - ancestors = [x | x <- Map.keys (children gr), not (hasParents x)] - hasParents x = Map.member x (parents gr) - -- all nodes in topological order "parents before children" - list = runIdentity $ reversePostOrder' ancestors (Identity . getChildren gr) - -{----------------------------------------------------------------------------- - Graph traversal -------------------------------------------------------------------------------} --- | Graph represented as map of immediate children. -type GraphM m a = a -> m [a] - --- | Computes the reverse post-order, --- listing all transitive children of a node. --- Each node is listed *before* all its children have been listed. -reversePostOrder :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a] -reversePostOrder x = reversePostOrder' [x] - --- | Reverse post-order from multiple nodes. --- INVARIANT: For this to be a valid topological order, --- none of the nodes may have a parent. -reversePostOrder' :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a] -reversePostOrder' xs children = fst <$> go xs [] Set.empty - where - go [] rpo visited = return (rpo, visited) - go (x:xs) rpo visited - | x `Set.member` visited = go xs rpo visited - | otherwise = do - xs' <- children x - -- visit all children - (rpo', visited') <- go xs' rpo (Set.insert x visited) - -- prepend this node as all children have been visited - go xs (x:rpo') visited' +ground :: Level +ground = 0 + +{----------------------------------------------------------------------------- + Graph +------------------------------------------------------------------------------} +{- | A directed graph +whose set of vertices is the set of all values of the type @v@ +and whose edges are associated with data of type @e@. + +Note that a 'Graph' does not have a notion of vertex membership +— by design, /all/ values of the type @v@ are vertices of the 'Graph'. +The main purpose of 'Graph' is to keep track of directed edges between +vertices; a vertex with at least one edge incident on it is called +a /connected vertex/. +For efficiency, only the connected vertices are stored. +-} +data Graph v e = Graph + { -- | Mapping from each vertex to its direct successors + -- (possibly empty). + outgoing :: !(Map v (Map v e)) + + -- | Mapping from each vertex to its direct predecessors + -- (possibly empty). + , incoming :: !(Map v (Map v e)) + + -- | Mapping from each vertex to its 'Level'. + -- Invariant: If x precedes y, then x has a lower level than y. + , levels :: !(Map v Level) + } deriving (Eq, Show) + +-- | The graph with no edges. +empty :: Graph v e +empty = Graph + { outgoing = Map.empty + , incoming = Map.empty + , levels = Map.empty + } + +-- | Get all direct successors of a vertex in a 'Graph'. +getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)] +getOutgoing Graph{outgoing} x = + map shuffle $ Map.toList $ fromMaybe Map.empty $ Map.lookup x outgoing + where + shuffle (x,y) = (y,x) + +-- | Get all direct predecessors of a vertex in a 'Graph'. +getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)] +getIncoming Graph{incoming} x = + Map.toList $ fromMaybe Map.empty $ Map.lookup x incoming + +-- | Get the 'Level' of a vertex in a 'Graph'. +getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level +getLevel Graph{levels} x = fromMaybe ground $ Map.lookup x levels + +-- | List all connected vertices, +-- i.e. vertices on which at least one edge is incident. +listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v] +listConnectedVertices Graph{incoming,outgoing} = + Map.keys $ (() <$ outgoing) `Map.union` (() <$ incoming) + +-- | Number of connected vertices, +-- i.e. vertices on which at least one edge is incident. +size :: (Eq v, Hashable v) => Graph v e -> Int +size Graph{incoming,outgoing} = + Map.size $ (() <$ outgoing) `Map.union` (() <$ incoming) + +-- | Number of edges. +edgeCount :: (Eq v, Hashable v) => Graph v e -> Int +edgeCount Graph{incoming,outgoing} = + (count incoming + count outgoing) `div` 2 + where + count = Map.foldl' (\a v -> Map.size v + a) 0 + +{----------------------------------------------------------------------------- + Insertion +------------------------------------------------------------------------------} +-- | Insert an edge from the first to the second vertex into the 'Graph'. +insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e +insertEdge (x,y) exy g0@Graph{..} = Graph + { outgoing + = Map.insertWith (\new old -> new <> old) x (Map.singleton y exy) + $ insertDefaultIfNotMember y Map.empty + $ outgoing + , incoming + = Map.insertWith (\new old -> new <> old) y (Map.singleton x exy) + . insertDefaultIfNotMember x Map.empty + $ incoming + , levels + = adjustLevels + $ levels0 + } + where + getLevel z = fromMaybe ground . Map.lookup z + levels0 + = insertDefaultIfNotMember x (ground-1) + . insertDefaultIfNotMember y ground + $ levels + + levelDifference = getLevel y levels0 - 1 - getLevel x levels0 + adjustLevel g x = Map.adjust (+ levelDifference) x g + adjustLevels ls + | levelDifference >= 0 = ls + | otherwise = L.foldl' adjustLevel ls predecessors + where + Identity predecessors = + reversePostOrder [x] (Identity . map fst . getIncoming g0) + +-- Helper function: Insert a default value if the key is not a member yet +insertDefaultIfNotMember + :: (Eq k, Hashable k) + => k -> a -> Map k a -> Map k a +insertDefaultIfNotMember x def = Map.insertWith (\_ old -> old) x def + +{----------------------------------------------------------------------------- + Deletion +------------------------------------------------------------------------------} +-- | TODO: Not implemented. +deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e +deleteEdge (x,y) g = Graph + { outgoing = undefined x g + , incoming = undefined y g + , levels = undefined + } + +-- | Remove all edges incident on this vertex from the 'Graph'. +deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +deleteVertex x = clearLevels . clearPredecessors x . clearSuccessors x + where + clearLevels g@Graph{levels} = g{levels = Map.delete x levels} + +-- | Remove all the edges that connect the given vertex to its predecessors. +clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +clearPredecessors x g@Graph{..} = g + { outgoing = foldr ($) outgoing + [ Map.adjust (Map.delete x) z | (z,_) <- getIncoming g x ] + , incoming = Map.delete x incoming + } + +-- | Remove all the edges that connect the given vertex to its successors. +clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +clearSuccessors x g@Graph{..} = g + { outgoing = Map.delete x outgoing + , incoming = foldr ($) incoming + [ Map.adjust (Map.delete x) z | (_,z) <- getOutgoing g x ] + } + +-- | Apply `deleteVertex` to all vertices which are not predecessors +-- of any of the vertices in the given list. +collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e +collectGarbage roots g@Graph{incoming,outgoing} = g + { incoming = Map.filterWithKey (\v _ -> isReachable v) incoming + -- incoming edges of reachable members are reachable by definition + , outgoing + = Map.map (Map.filterWithKey (\v _ -> isReachable v)) + $ Map.filterWithKey (\v _ -> isReachable v) outgoing + } + where + isReachable x = x `Set.member` reachables + reachables + = Set.fromList . runIdentity + $ reversePostOrder roots + $ Identity . map fst . getIncoming g + +{----------------------------------------------------------------------------- + Topological sort +------------------------------------------------------------------------------} +-- | If the 'Graph' is acyclic, return a topological sort, +-- that is a linear ordering of its connected vertices such that +-- each vertex occurs before its successors. +-- +-- (Vertices that are not connected are not listed in the topological sort.) +-- +-- https://en.wikipedia.org/wiki/Topological_sorting +topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v] +topologicalSort g@Graph{incoming} = + runIdentity $ reversePostOrder roots (Identity . map snd . getOutgoing g) + where + -- all vertices that have no (direct) predecessors + roots = [ x | (x,preds) <- Map.toList incoming, null preds ] + +data Step = Next | Stop + +-- | Starting from a list of vertices without predecessors, +-- walk through all successors, but in such a way that every vertex +-- is visited before its predecessors. +-- For every vertex, if the function returns `Next`, then +-- the successors are visited, otherwise the walk at the vertex +-- stops prematurely. +-- +-- > topologicalSort g = +-- > runIdentity $ walkSuccessors (roots g) (pure Next) g +-- +walkSuccessors + :: forall v e m. (Monad m, Eq v, Hashable v) + => [v] -> (v -> m Step) -> Graph v e -> m [v] +walkSuccessors xs step g = go (Q.fromList $ zipLevels xs) Set.empty [] + where + zipLevels vs = [(getLevel g v, v) | v <- vs] + + go :: Queue Level v -> Set v -> [v] -> m [v] + go q0 seen visits = case Q.minView q0 of + Nothing -> pure $ reverse visits + Just (v,q1) + | v `Set.member` seen -> go q1 seen visits + | otherwise -> do + next <- step v + let q2 = case next of + Stop -> q1 + Next -> + let successors = zipLevels $ map snd $ getOutgoing g v + in insertList q1 successors + go q2 (Set.insert v seen) (v:visits) + + +insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v +insertList = L.foldl' (\q (k,v) -> Q.insert k v q) + +walkSuccessors_ + :: (Monad m, Eq v, Hashable v) + => [v] -> (v -> m Step) -> Graph v e -> m () +walkSuccessors_ xs step g = walkSuccessors xs step g >> pure () + +{----------------------------------------------------------------------------- + Debugging +------------------------------------------------------------------------------} +-- | Map to a string in @graphviz@ dot file format. +showDot + :: (Eq v, Hashable v) + => (v -> String) -> Graph v e -> String +showDot fv g = unlines $ + [ "digraph mygraph {" + , " node [shape=box];" + ] <> map showVertex (listConnectedVertices g) + <> ["}"] + where + showVertex x = + concat [ " " <> showEdge x y <> "; " | (_,y) <- getOutgoing g x ] + showEdge x y = escape x <> " -> " <> escape y + escape = show . fv diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/GraphGC.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphGC.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/GraphGC.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphGC.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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, ()) diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/GraphTraversal.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphTraversal.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/GraphTraversal.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphTraversal.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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' diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/IO.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/IO.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/IO.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/IO.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Plumbing.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Plumbing.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Plumbing.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Plumbing.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Ref.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Ref.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Ref.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Ref.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 #) diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Types.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Types.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Types.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Types.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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`. - --} diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Util.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Util.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Low/Util.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Util.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Combinators.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Combinators.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Combinators.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Combinators.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 - - p1 <- newPulse "switchP_in" switch :: Build (Pulse ()) - p1 `dependOn` pp - p2 <- newPulse "switchP_out" eval - p2 `dependOn` p - p2 `keepAlive` p1 - return p2 + Nothing -> pure () + Just new -> liftBuildP $ pout `changeParent` new + pure Nothing + + pin <- newPulse "switchP_in" switch :: Build (Pulse ()) + pin `dependOn` pp + + pout `dependOn` p -- initial dependency + pout `keepAlive` pin -- keep switches happening + pure pout diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Compile.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Compile.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Compile.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Compile.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Evaluation.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Evaluation.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Evaluation.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Evaluation.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 } diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/IO.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/IO.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/IO.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/IO.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Plumbing.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Plumbing.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Plumbing.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Plumbing.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Test.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Test.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Test.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Test.hs 2001-09-09 01:46:40.000000000 +0000 @@ -1,7 +1,7 @@ +{-# LANGUAGE RecursiveDo #-} {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.Mid.Test where import Reactive.Banana.Prim.Mid diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Types.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Types.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid/Types.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Types.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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`. + +-} diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Prim/Mid.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 {----------------------------------------------------------------------------- diff -Nru haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Types.hs haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Types.hs --- haskell-reactive-banana-1.3.1.0/src/Reactive/Banana/Types.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/src/Reactive/Banana/Types.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Combinators.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Combinators.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Combinators.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Combinators.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 + diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Plumbing.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Plumbing.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Plumbing.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Plumbing.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Space.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Space.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/High/Space.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Space.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/Gen.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Gen.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/Gen.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Gen.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/Graph.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Graph.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/Graph.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Graph.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/GraphGC.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/GraphGC.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Low/GraphGC.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/GraphGC.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Mid/Space.hs haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Mid/Space.hs --- haskell-reactive-banana-1.3.1.0/test/Reactive/Banana/Test/Mid/Space.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Mid/Space.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/test/reactive-banana-tests.hs haskell-reactive-banana-1.3.2.0/test/reactive-banana-tests.hs --- haskell-reactive-banana-1.3.1.0/test/reactive-banana-tests.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/reactive-banana-tests.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 + ] + ] diff -Nru haskell-reactive-banana-1.3.1.0/test/space.hs haskell-reactive-banana-1.3.2.0/test/space.hs --- haskell-reactive-banana-1.3.1.0/test/space.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/test/space.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 diff -Nru haskell-reactive-banana-1.3.1.0/tests/Main.hs haskell-reactive-banana-1.3.2.0/tests/Main.hs --- haskell-reactive-banana-1.3.1.0/tests/Main.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/tests/Main.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 - diff -Nru haskell-reactive-banana-1.3.1.0/tests/Plumbing.hs haskell-reactive-banana-1.3.2.0/tests/Plumbing.hs --- haskell-reactive-banana-1.3.1.0/tests/Plumbing.hs 2001-09-09 01:46:40.000000000 +0000 +++ haskell-reactive-banana-1.3.2.0/tests/Plumbing.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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