reactive-banana-1.3.2.0/0000755000000000000000000000000007346545000013064 5ustar0000000000000000reactive-banana-1.3.2.0/CHANGELOG.md0000644000000000000000000003031407346545000014676 0ustar0000000000000000Changelog for the `reactive-banana` package ------------------------------------------- **Version 1.3.2.0** (2023-01-22) * Fixed multiple space leaks for dynamic event switching by completely redesigning low-level internals. Added automated tests on garbage collection and space leaks in order to make sure that the leaks stay fixed. [#261][], [#267][], [#268][] [#268]: https://github.com/HeinrichApfelmus/reactive-banana/pull/268 [#267]: https://github.com/HeinrichApfelmus/reactive-banana/pull/267 [#261]: https://github.com/HeinrichApfelmus/reactive-banana/issues/261 **Version 1.3.1.0** (2022-08-11) * Various internal performance improvements. [#257][], [#258][] * Fix a space leak in dynamic event switching. [#256][] * Reduce memory usage of `stepper`/`accumB`. [#260][] * Prevent a deadlock if the network crashes when evaluating a `Behavior` or `Event`. [#262][] [#257]: https://github.com/HeinrichApfelmus/reactive-banana/pull/257 [#258]: https://github.com/HeinrichApfelmus/reactive-banana/pull/258 [#256]: https://github.com/HeinrichApfelmus/reactive-banana/pull/256 [#262]: https://github.com/HeinrichApfelmus/reactive-banana/pull/262 [#260]: https://github.com/HeinrichApfelmus/reactive-banana/pull/260 **Version 1.3.0.0** (2022-03-28) * Added `Semigroup` and `Monoid` instances to `Moment` and `MomentIO`. [#223][] * Add `@>` operator. [#229][] * `switchE` now takes an initial event. This is breaking change. The previous behavior can be restored by using `switchE never`. [#165][] * Triggering an `AddHandler` no longer allocates, leading to a minor performance improvement. [#237][] * A new `once` combinator has been added that filters an `Event` so it only fires once. [#239][] * `MonadMoment` instances have been added for all possibly monad transformers (from the `transformers` library). [#248][] * Some internal refactoring to reduce allocations and improve performance. [#238][] * The `Reactive.Banana.Prim` hierarchy has been changed to better reflect the abstraction hierarchy. [#241][] [#165]: https://github.com/HeinrichApfelmus/reactive-banana/pull/165 [#229]: https://github.com/HeinrichApfelmus/reactive-banana/pull/229 [#223]: https://github.com/HeinrichApfelmus/reactive-banana/pull/223 [#237]: https://github.com/HeinrichApfelmus/reactive-banana/pull/237 [#238]: https://github.com/HeinrichApfelmus/reactive-banana/pull/238 [#239]: https://github.com/HeinrichApfelmus/reactive-banana/pull/239 [#241]: https://github.com/HeinrichApfelmus/reactive-banana/pull/241 [#248]: https://github.com/HeinrichApfelmus/reactive-banana/pull/248 **Version 1.2.2.0** * Optimize the implementation of `Graph.listParents` [#209][] * Replace a use of `foldl` with `foldl'`. [#212][] * Simplify the internal `mkWeakIORef` function. [#154][] * Add `merge` and `mergeWith` combinators. [#163][], [#220][] * Make internal SCC pragmas compatible with the GHC 9.0 parser. [#208][] * Change `insertWith (flip (++))` to `insertWith (++)` in `insertEdge`. [#211][] * Add `Semigroup a => Semigroup (Behavior a)` and `Monoid a => Monoid (Behavior a)` instances. [#185][] * Loosen the upper-bound for `hashable` and `semigroups`. [#205][] [#154]: https://github.com/HeinrichApfelmus/reactive-banana/pull/154 [#163]: https://github.com/HeinrichApfelmus/reactive-banana/pull/163 [#185]: https://github.com/HeinrichApfelmus/reactive-banana/pull/185 [#205]: https://github.com/HeinrichApfelmus/reactive-banana/pull/205 [#208]: https://github.com/HeinrichApfelmus/reactive-banana/pull/208 [#209]: https://github.com/HeinrichApfelmus/reactive-banana/pull/209 [#211]: https://github.com/HeinrichApfelmus/reactive-banana/pull/211 [#212]: https://github.com/HeinrichApfelmus/reactive-banana/pull/212 [#220]: https://github.com/HeinrichApfelmus/reactive-banana/pull/219 **version 1.2.1.0** * Add `Num`, `Floating`, `Fractional`, and `IsString` instances for `Behavior`. [#34][] * Support `containers-0.6`. [#191][] [#34]: https://github.com/HeinrichApfelmus/reactive-banana/pull/34 [#191]: https://github.com/HeinrichApfelmus/reactive-banana/pull/191 **version 1.2.0.0** * Make `MonadFix` superclass of `MonadMoment`. [#128][] * Add `Semigroup` and `Monoid` instances for `Event`. [#104][] * Semigroup compatibility with GHC 8.4.1 [#168][] * Increased upper-bound on `pqueue`. [#128]: https://github.com/HeinrichApfelmus/reactive-banana/pull/128 [#104]: https://github.com/HeinrichApfelmus/reactive-banana/issues/104 [#168]: https://github.com/HeinrichApfelmus/reactive-banana/pull/168 **version 1.1.0.1** * Adapt library to work with GHC-8.0.1. **version 1.1.0.0** * Fix bug: Types of `switchB` and `switchE` need to be in the `Moment` monad. * Clean up and simplify model implementation in the `Reactive.Banana.Model` module. * Update type signatures of the `interpret*` functions to make it easier to try FRP functions in the REPL. * Remove `showNetwork` function. **version 1.0.0.1** * Improve documentation. * Add prose section on recursion. * Improve explanation for the `changes` function. * Bump `transfomers` dependency. * Remove defunct `UseExtensions` flag from cabal file. **version 1.0.0.0** The API has been redesigned significantly in this version! * Remove phantom type parameter `t` from `Event`, `Behavior` and `Moment` types. * Change accumulation functions (`accumB`, `accumE`, `stepper`) to have a monadic result type. * Merge module `Reactive.Banana.Switch` into module `Reactive.Banana.Combinators`. * Simplify types of the switching functions (`switchE`, `switchB`, `observeB`, `execute`). * Remove functions `trimE` and `trimB`. * Remove types `AnyMoment` and `Identity`. * Remove `Frameworks` class constraint, use `MomentIO` type instead. * Add class `MonadMoment` for both polymorphism over the `Moment` and `MomentIO` types. * Change type `Event` to only allow a single event per moment in time. * Remove function `union`. Use `unionWith` instead. * Change function `unions` to only merge events of type `Event (a -> a)`. * Remove module `Reactive.Banana.Experimental.Calm`. * Change the model implementation in the module `Reactive.Banana.Model` to the new API as well. Other changes: * Add `mapEventIO` utility function to build an Event that contains the result of an IO computation. * Add `newBehavior` utility function to build a Behavior that can be updated with a `Handler`. * Add illustrations to the API documentation. **version 0.9.0.0** * Implement garbage collection for dynamically switched events. * Fix issue [#79][] where recursive declarations would sometimes result in dropped events. * Limit value recursion in the `Moment` monad slightly. * Change `initial` and `valueB` to behave subtly different when it comes to value recursion in the `Moment` monad. * Add `Functor`, `Applicative` and `Monad` instances for the `FrameworksMoment` type. * Depend on the [pqueue][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC. [#79]: https://github.com/HeinrichApfelmus/reactive-banana/issues/79 **version 0.8.1.2** * Depend on the [psqueues][] package instead of the [pqueue][] package for the priority queue. [psqueues]: https://hackage.haskell.org/package/psqueues [pqueue]: http://hackage.haskell.org/package/pqueue **version 0.8.1.1** * Links to the Haskell wiki now point to the `http://wiki.haskell.org` subdomain. **version 0.8.1.0** * Module `Reactive.Banana.Switch` now adheres to the "Functor Applicative Monad Proposal" proposal][amp-proposal]. [amp-proposal]: https://wiki.haskell.org/Functor-Applicative-Monad_Proposal **version 0.8.0.4** * Just a re-upload. The previous archive was broken. **version 0.8.0.3** * Export the `Future` type. * Restrict `containers` dependency to lower bound 0.5. **version 0.8.0.2** * Fix compilation issue with hiding `empty` from the module `Reactive.Banana.Prim.Order`. **version 0.8.0.1** * New examples `Counter.hs` and `Octave.hs`. * Bump `transfomers` dependency. **version 0.8.0.0** * A new module `Reactive.Banana.Prim` exports primitive combinators that you can use to implement your own FRP library with a different API. * The push-driven implementation in `Reactive.Banana.Prim` now has the performance characteristics of an actual push-driven implementation. Some work has gone into optimizing constant factors as well. However there is still no garbage collection for dynamically created events and behaviors. * The `accumE` and `accumB` combinators evaluate their state to WHNF to avoid a space leak. (Fixes issue #52). On the other hand, `Behavior` values are evaluated on demanded, i.e. only when required by the apply combinator `<@>` or similar. * Recursion between events and behaviors should now work as advertised. (Fixed issue #56). * The deprecated `liftIONow` function has been removed. * The type of the `changes` function now indicates that the new Behavior value is only available in the context of `reactimate`. A variant `reactimate'` makes this explicit. * The module `Control.Event.Handler` now exports the `AddHandler` type, which is now a `newtype`. The module `Reactive.Banana.Frameworks.AddHandler` has been removed. **version 0.7.1.0** * Deprecate the `liftIONow` function in favor of `liftIO`. **version 0.7.0.0** * *Dynamic event switching*. Combinators are now available in the module `Reactive.Banana.Switch`. * Rename `NetworkDescription` to `Moment`, add class constraint `Frameworks t`. * No longer compiles with the JavaScript backend of the Utrecht Haskell compiler. * Change the `changes` combinator to be less useful. **version 0.6.0.0** * Can now be compiled with the JavaScript backend of the Utrecht Haskell compiler. * The push-driven implementations needs the `UseExtensions` flag to work. This flag is enabled by default. * Minor module reorganization. **version 0.5.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2012/03/25-frp-banana-0-5.html) This update includes numerous changes, in particular a complete overhaul of the internal implementation. Here a partial list. * Add `collect`, `spill` and `unionWith` combinators to deal with simultaneous events. * Remove general `Monoid` instance for `Event` to simplify reasoning about simultaneous events. * Add `initial` and `changes` combinators that allow you to observe updates to `Behavior`. Remove the `Reactive.Banana.Incremental` module. * Rename most modules, * Change type signatures: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type. **version 0.4.3.1** * Model implementation of `accumE` now has the intended semantics. **version 0.4.3.0** * Change semantics: `IO` actions from inside `reactimate` may now interleave as dictated by your event-based framework (issue #15). * Fix bug: compiling a network twice no longer fails due to lingering global state (issue #16). * Change type: remove `Typeable` constraint from `interpret` and `interpretAsHandler`. * Misc: Remove the `BlackBoard` application from the repository. **version 0.4.2.0** * Change type: remove `Typeable` constraint from `fromAddHandler`. * Misc: the `Vault` data type gets its own package. * Misc: `reactive-banana-wx` now compiles properly with cabal. * Add some more examples to the `reactive-banana-wx` package. **version 0.4.1.0** * Add `<@>` operator for more convenience when using `apply`. * Add support for value recursion to the `NetworkDescription` monad. * Add many examples to `reactive-banana-wx`. **version 0.4.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/07/07-frp-banana-0-4.html) * Add function `fromPoll` to obtain behaviors from mutable data. * Change name: `run` is now called `actuate`. * Add derived data type `Discrete`. * Add function `interpretAsHandler`. **version 0.3.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-3.html) * change: event networks are now first-class values, you can `pause` or `run` them. * change type: `AddHandler` now expects a way to unregister event handlers. * add example `RunPause.hs` **version 0.2.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-2.html) * change: now implements proper semantics as pioneered by Conal Elliott * model implementation for semantics * push-driven implementation for efficiency * add example `SlotMachine.hs` **version 0.1.0.0** * initial release reactive-banana-1.3.2.0/LICENSE0000644000000000000000000000300007346545000014062 0ustar0000000000000000Copyright (c)2011-2015, Heinrich Apfelmus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Heinrich Apfelmus nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. reactive-banana-1.3.2.0/Setup.hs0000644000000000000000000000005607346545000014521 0ustar0000000000000000import Distribution.Simple main = defaultMain reactive-banana-1.3.2.0/benchmark/0000755000000000000000000000000007346545000015016 5ustar0000000000000000reactive-banana-1.3.2.0/benchmark/Main.hs0000644000000000000000000000561507346545000016245 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NumericUnderscores #-} module Main ( main ) where import Control.Monad (replicateM, replicateM_, forM_) import qualified Data.IntMap.Strict as IM import Reactive.Banana.Combinators ( Event, Behavior, MonadMoment, filterE, accumE, switchB, accumB ) import Reactive.Banana.Frameworks (MomentIO, newAddHandler, fromAddHandler, compile, actuate, Handler, reactimate) import Reactive.Banana ( Event, Behavior, MonadMoment ) import System.Random (randomRIO) import Test.Tasty (withResource) import Test.Tasty.Bench (env, defaultMain, bgroup, bench, whnfIO) main :: IO () main = defaultMain $ [ mkBenchmarkGroup netsize | netsize <- [ 1, 2, 4, 8, 16, 32, 64, 128 ] ] ++ [ boringBenchmark ] where mkBenchmarkGroup netsize = withResource (setupBenchmark netsize) mempty $ \getEnv -> bgroup ("netsize = " <> show netsize) [ mkBenchmark getEnv steps | steps <- [ 1, 2, 4, 8, 16, 32, 64, 128] ] where mkBenchmark getEnv duration = bench ("duration = " <> show duration) $ whnfIO $ do (triggers, clock) <- getEnv let trigMap = IM.fromList $ zip [0..netsize-1] triggers forM_ [1..duration] $ \step -> do randomRs <- replicateM 10 $ randomRIO (0,netsize-1) clock step forM_ randomRs $ \ev -> maybe (error "benchmark: trigger not found") ($ ()) $ IM.lookup ev trigMap boringBenchmark = withResource setup mempty $ \getEnv -> bench "Boring" $ whnfIO $ do tick <- getEnv {-# SCC ticks #-} replicateM_ 1_000_000 $ {-# SCC tick #-} tick () where setup = do (tick, onTick) <- newAddHandler network <- compile $ do e <- fromAddHandler tick reactimate $ return <$> e actuate network return onTick setupBenchmark :: Int -> IO ([Handler ()], Handler Int) setupBenchmark netsize = do (handlers, triggers) <- unzip <$> replicateM netsize newAddHandler (clock , trigger ) <- newAddHandler let networkD :: MomentIO () networkD = do es :: [Event ()] <- mapM fromAddHandler handlers e :: Event Int <- fromAddHandler clock countBs :: [Behavior Int] <- traverse count es let step10E :: Event Int step10E = filterE (\cnt -> cnt `rem` 10 == 0) e selectedB_E :: Event (Behavior Int) <- do fmap head <$> accumE countBs (keepTail <$ step10E) selectedB :: Behavior Int <- switchB (head countBs) selectedB_E return () count :: MonadMoment m => Event () -> m (Behavior Int) count e = accumB 0 ((+1) <$ e) actuate =<< compile networkD return (triggers, trigger) where keepTail :: [a] -> [a] keepTail (_:y:zs) = y:zs keepTail [x] = [x] keepTail [] = [] reactive-banana-1.3.2.0/doc/examples/0000755000000000000000000000000007346545000015447 5ustar0000000000000000reactive-banana-1.3.2.0/doc/examples/ActuatePause.hs0000644000000000000000000000470207346545000020372 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: Actuate and pause an event network ------------------------------------------------------------------------------} import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub) import System.Random import System.IO import Debug.Trace import Data.IORef import Reactive.Banana import Reactive.Banana.Frameworks main :: IO () main = do displayHelpMessage sources <- (,) <$> newAddHandler <*> newAddHandler network <- setupNetwork sources actuate network eventLoop sources network displayHelpMessage :: IO () displayHelpMessage = mapM_ putStrLn $ "Commands are:": " count - send counter event": " pause - pause event network": " actuate - actuate event network": " quit - quit the program": "": [] -- Read commands and fire corresponding events eventLoop :: (EventSource (),EventSource EventNetwork) -> EventNetwork -> IO () eventLoop (escounter, espause) network = loop where loop = do putStr "> " hFlush stdout s <- getLine case s of "count" -> fire escounter () "pause" -> fire espause network "actuate" -> actuate network "quit" -> return () _ -> putStrLn $ s ++ " - unknown command" when (s /= "quit") loop {----------------------------------------------------------------------------- Event sources ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you type EventSource a = (AddHandler a, a -> IO ()) addHandler :: EventSource a -> AddHandler a addHandler = fst fire :: EventSource a -> a -> IO () fire = snd {----------------------------------------------------------------------------- Program logic ------------------------------------------------------------------------------} -- Set up the program logic in terms of events and behaviors. setupNetwork :: (EventSource (),EventSource EventNetwork) -> IO EventNetwork setupNetwork (escounter, espause) = compile $ do ecounter <- fromAddHandler (addHandler escounter) epause <- fromAddHandler (addHandler espause ) ecount <- accumE 0 $ (+1) <$ ecounter reactimate $ fmap print ecount reactimate $ fmap pause epause reactive-banana-1.3.2.0/doc/examples/Counter.hs0000644000000000000000000000514207346545000017424 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: Actuate and pause an event network acting as a counter ------------------------------------------------------------------------------} import Control.Monad (when) import System.IO import Reactive.Banana import Reactive.Banana.Frameworks main :: IO () main = do displayHelpMessage sources <- (,,) <$> newAddHandler <*> newAddHandler <*> newAddHandler network <- setupNetwork sources actuate network eventLoop sources network displayHelpMessage :: IO () displayHelpMessage = mapM_ putStrLn $ "Commands are:": " + - increase counterUp event": " - - decrease counterUp event": " p - pause event network": " a - actuate event network": " q - quit the program": "": [] -- Read commands and fire corresponding events eventLoop :: (EventSource (), EventSource (),EventSource EventNetwork) -> EventNetwork -> IO () eventLoop (eplus, eminus, espause) network = loop where loop = do putStr "> " hFlush stdout hSetBuffering stdin NoBuffering s <- getChar case s of '+' -> fire eplus () '-' -> fire eminus () 'p' -> fire espause network 'a' -> actuate network 'q' -> return () _ -> putStrLn $ [s] ++ " - unknown command" when (s /= 'q') loop {----------------------------------------------------------------------------- Event sources ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you type EventSource a = (AddHandler a, a -> IO ()) addHandler :: EventSource a -> AddHandler a addHandler = fst fire :: EventSource a -> a -> IO () fire = snd {----------------------------------------------------------------------------- Program logic ------------------------------------------------------------------------------} -- Set up the program logic in terms of events and behaviors. setupNetwork :: (EventSource (), EventSource (), EventSource EventNetwork) -> IO EventNetwork setupNetwork (eplus, eminus, espause) = compile $ do counterUp <- fromAddHandler (addHandler eplus) counterDown <- fromAddHandler (addHandler eminus) epause <- fromAddHandler (addHandler espause) ecount <- accumE 0 $ unions [ (+1) <$ counterUp , subtract 1 <$ counterDown ] reactimate $ fmap print ecount reactimate $ fmap pause epause reactive-banana-1.3.2.0/doc/examples/Octave.hs0000644000000000000000000000500107346545000017220 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: "The world's worst synthesizer" from the unofficial tutorial. ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-} -- allows recursive do notation -- mdo -- ... module Main where import Data.Char (toUpper) import Control.Monad (forever) import System.IO (BufferMode(..), hSetEcho, hSetBuffering, stdin) import Reactive.Banana import Reactive.Banana.Frameworks type Octave = Int data Pitch = PA | PB | PC | PD | PE | PF | PG deriving (Eq, Enum) -- Mapping between pitch and the char responsible for it. pitchChars :: [(Pitch, Char)] pitchChars = [(p, toEnum $ fromEnum 'a' + fromEnum p) | p <- [PA .. PG]] -- Reverse of pitchChars charPitches :: [(Char, Pitch)] charPitches = [(b, a) | (a, b) <- pitchChars] data Note = Note Octave Pitch instance Show Pitch where show p = case lookup p pitchChars of Nothing -> error "cannot happen" Just c -> [toUpper c] instance Show Note where show (Note o p) = show p ++ show o -- Filter and transform events at the same time. filterMapJust :: (a -> Maybe b) -> Event a -> Event b filterMapJust f = filterJust . fmap f -- Change the original octave by adding a number of octaves, taking -- care to limit the resulting octave to the 0..10 range. changeOctave :: Int -> Octave -> Octave changeOctave d = max 0 . min 10 . (d+) -- Get the octave change for the '+' and '-' chars. getOctaveChange :: Char -> Maybe Int getOctaveChange c = case c of '+' -> Just 1 '-' -> Just (-1) _ -> Nothing makeNetworkDescription :: AddHandler Char -> MomentIO () makeNetworkDescription addKeyEvent = do eKey <- fromAddHandler addKeyEvent let eOctaveChange = filterMapJust getOctaveChange eKey bOctave <- accumB 3 (changeOctave <$> eOctaveChange) let ePitch = filterMapJust (`lookup` charPitches) eKey bPitch <- stepper PC ePitch let bNote = Note <$> bOctave <*> bPitch foo = Note 0 PA eNoteChanged <- changes bNote reactimate' $ fmap (\n -> putStrLn ("Now playing " ++ show n)) <$> eNoteChanged main :: IO () main = do (addKeyEvent, fireKey) <- newAddHandler network <- compile (makeNetworkDescription addKeyEvent) actuate network hSetEcho stdin False hSetBuffering stdin NoBuffering forever (getChar >>= fireKey) reactive-banana-1.3.2.0/doc/examples/SlotMachine.hs0000644000000000000000000001257707346545000020225 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: Slot machine ------------------------------------------------------------------------------} {-# LANGUAGE ScopedTypeVariables #-} -- allows pattern signatures like -- do -- (b :: Behavior Int) <- stepper 0 ... {-# LANGUAGE RecursiveDo #-} -- allows recursive do notation -- mdo -- ... import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub) import System.Random import System.IO import Debug.Trace import Data.IORef import Reactive.Banana as R import Reactive.Banana.Frameworks as R main :: IO () main = do displayHelpMessage sources <- makeSources network <- compile $ networkDescription sources actuate network eventLoop sources displayHelpMessage :: IO () displayHelpMessage = mapM_ putStrLn $ "-----------------------------": "- THE REACTIVE SLOT MACHINE -": "------ WIN A BANANA ---------": "": "Commands are:": " coin - insert a coin": " play - play one game": " quit - quit the program": "": [] -- Create event sources corresponding to coin and play makeSources = (,) <$> newAddHandler <*> newAddHandler -- Read commands and fire corresponding events eventLoop :: (EventSource (), EventSource ()) -> IO () eventLoop (escoin,esplay) = loop where loop = do putStr "> " hFlush stdout s <- getLine case s of "coin" -> fire escoin () -- fire corresponding events "play" -> fire esplay () "quit" -> return () _ -> putStrLn $ s ++ " - unknown command" when (s /= "quit") loop {----------------------------------------------------------------------------- Event sources ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you type EventSource a = (AddHandler a, a -> IO ()) addHandler :: EventSource a -> AddHandler a addHandler = fst fire :: EventSource a -> a -> IO () fire = snd {----------------------------------------------------------------------------- Program logic ------------------------------------------------------------------------------} type Money = Int -- State of the reels, consisting of three numbers from 1-4. Example: "222" type Reels = (Int,Int,Int) -- A win consist of either double or triple numbers data Win = Double | Triple -- Program logic in terms of events and behaviors. networkDescription :: (EventSource (), EventSource ()) -> MomentIO () networkDescription (escoin,esplay) = mdo -- initial random number generator initialStdGen <- liftIO $ newStdGen -- Obtain events corresponding to the coin and play commands ecoin <- fromAddHandler (addHandler escoin) eplay <- fromAddHandler (addHandler esplay) -- The state of the slot machine is captured in Behaviors. -- State: credits that the player has to play the game -- The ecoin event adds a coin to the credits -- The edoesplay event removes money -- The ewin event adds credits because the player has won (ecredits :: Event Money, bcredits :: Behavior Money) <- mapAccum 0 . fmap (\f x -> (f x,f x)) $ unions $ [ addCredit <$ ecoin , removeCredit <$ edoesplay , addWin <$> ewin ] let -- functions that change the accumulated state addCredit = (+1) removeCredit = subtract 1 addWin Double = (+5) addWin Triple = (+20) -- Event: does the player have enough money to play the game? emayplay :: Event Bool emayplay = (\credits _ -> credits > 0) <$> bcredits <@> eplay -- Event: player has enough coins and plays edoesplay :: Event () edoesplay = () <$ filterE id emayplay -- Event: event that fires when the player doesn't have enough money edenied :: Event () edenied = () <$ filterE not emayplay -- State: random number generator (eroll :: Event Reels, bstdgen :: Behavior StdGen) -- accumulate the random number generator while rolling the reels <- mapAccum initialStdGen $ roll <$> edoesplay let -- roll the reels roll :: () -> StdGen -> (Reels, StdGen) roll () gen0 = ((z1,z2,z3),gen3) where random = randomR(1,4) (z1,gen1) = random gen0 (z2,gen2) = random gen1 (z3,gen3) = random gen2 -- Event: it's a win! ewin :: Event Win ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll checkWin (z1,z2,z3) | length (nub [z1,z2,z3]) == 1 = Just Triple | length (nub [z1,z2,z3]) == 2 = Just Double | otherwise = Nothing -- ecredits <- changes bcredits reactimate $ putStrLn . showCredit <$> ecredits reactimate $ putStrLn . showRoll <$> eroll reactimate $ putStrLn . showWin <$> ewin reactimate $ putStrLn "Not enough credits!" <$ edenied showCredit money = "Credits: " ++ show money showRoll (z1,z2,z3) = "You rolled " ++ show z1 ++ show z2 ++ show z3 showWin Double = "Wow, a double!" showWin Triple = "Wowwowow! A triple! So awesome!" reactive-banana-1.3.2.0/doc/0000755000000000000000000000000007346545000013631 5ustar0000000000000000reactive-banana-1.3.2.0/doc/frp-behavior.png0000644000000000000000000004435607346545000016737 0ustar0000000000000000PNG  IHDR2;u'yiCCPICC ProfilehPTMϙ9s9$Qr9#"IDD$ $H$ 1DDAQD {ڭڭs歮9-$$FAalvlD@ssQ7333DX~B fPLyCq>yAq;ЩDGDQP̀G{ ԕj ЄbWg^TPšgi=00zM~ 󹇄AcAsb77?k۲{c^@847jdjg0}/@9  0*඄Rp_'pCKUVTH Tq @@ #l  (J*hz!`Vpp^/@,,"Pe@%P 4-m#`X ?S @ dA!P@]@0 s`6X- 3" n FQXa|0 Lfsyat%X) {v`_s*p- OK7]c 'Ep# "GT"k}$$Gr %ZHk72,G" 7#ńEilPDT>ՋzZGqh$ZGg+]i(`0ޘdL3Y|Xe 6{{ۇ]8V< p_D<^og ('AH%: DK$#V$L$$$$$$K$G26ѤH{H~''S s$K"A6JM#%$! #OAN!GBq9%H)@iEDHJʆ*5Zڃz 1M"M32-V6vF7E^ޕ  B .  ~0 322N2berg*bf,\EŃ41k!/[]]vvSTo8h888nqprjpFp|΅R zʍV^AT,"yxx+yU  ~rz t,,!+\)L()'r[dGMN詘XXغ8xD-lW%R:RRR?C[xT˼e=#["\FZSy*y+BEjbN77x|Z>+K+* TU.,26~QWKSVTwTS!HFM摖EڡC:x[:/jyzz1z4w VuچEFrFFLLMMMCLhSZPXx[ XRXXYQYY [ZY0D<崍}b'hnl/mgPəGcSӄ3ss)K.\u]k\Oθ:zv]=}Cã^/o1<=C&_?ntM %^ K`RJr`P0ǰpߑNQQQ*'11C,Iq*qq'C , +ʉIgcȦZvQ͝;wtfddg\пАΜz]=uQb]23oϥKou//\,/*xJs!0p,:Q]T,W\Zĩd4tL[_>s]_+l*z+++nhިTWVWV9S3TQ{vΨ&͘j ؆FƲ&ɣiȭ[?Z[.iimv>ۑqxh@gA.;bwJn^Bodjn_{?Czǻvw \4ZK?8<9"5Rux?Q1qx%)i銇?rx45#70K;{a9ݹyB'O>UzڲȺ |͒s/X^俄|գe+\+Vq_{^Z3\ZX۠߸ nFnqz3Vm6v;];.;O qev/iGߏ?YW, ݗAW+Ծu |g~Gҏß?7~;=-4?Pi:">+J^e@ ЂHo# xBi "5:P 4@@t pRL u)P @k0b:xl!ς p<ia0aLf KeÊ`հ6哰E¹p5 _ }(!C!j3+D4DхxXB ~" HR/7=BPf(OT,*U|&9hS':]n@C?Ca&$㎉\Œb1X,/V k bob/_q8~k=mxV"7o pAp/ DRшO&6'H$$:$^$$$$ۤR~RR\Y}2r2I2kRA5r89/!y0e " &%Rw !36U U=w {7h4r4gihhВ*Ҏ1EU=;ϠC@P0#c..S"S *3 *ss E /V!Vg|ldz>[_`g`<r*:(ȃQie'W1_?@A`2D!a!o*W4f9D@%NOޢ5 I 3%I?%$%H~ j$-*{OFX&PE棬ll쾜\\ܡ||B¨"RQO1GqV\JX2rQp^ߪlyջjk\ИY%5MԶ֮ӉչKеѽ^OJ/IoJJYQ@ `ɐ0pcdeTeX8 I=SF#3fo%--B,-,]-;@+ jk-omll^ &qEM3ُ8P9x;!9v#ɱ wsnv]l\]AWf7[YY(w'NG'ר7wOςoK?I7JW?hx+L<2*&V^+:-y/>*"j6?\j|̕qq]~ l b9oԓʓ-[R0)gSSR#R O[?tt[`̈xzABLӬ3YaُsrrjV\t؟GإK =/^QRvg}aUWI}f~8xDb^Qis,QPynuJʼʏ7LoUUVWKT_Zc]]K[SNM4444bgD.7ܲL߼ҢRՊhjlݢNmG\m՝N.;6w7{tz!>+?vnO݃ CCB=.FLOL2Oܙ2f>7a#G>XͲf~zlxh{؂B'J=-_D,,>}n\y )/v^*eUչpkk-4Iۛfod5Vmmw ww+@ayWkyr/~oǎOt?79/&_0l5yHwtM[Qw7~xSgϓ_gm$iſ7?Qa:d1ր >߇@_qb2&!` x,/5? @dy@PT@st\> L /ꏃ CaLKTa0[;d LU 3N3pmO+! d{"!PE%9D!уBB!N!kB `dوDCEDdP(T* UBM^CƎG& 7G4#1`R0%4fsbD5l-1dqgjqøew<^o_Gc=A`M'\&f {Dek*4U*UcjnjSX4塵Mm}Fsˢۤ'W/`ɐ𚑄Q1q'?=S&S/;f:f=,Xy_R :%SkG׳?q(qqXDprrsr\R\\e\ 4r9dJ>=$N~V~k#2A``[!f!kBBo 19 mc,H%. #EBXWVbMINPr^(e uAjLVN> ه(,ANPOInG_OIBBGEQPNC%YXSeuʓ*xS+*K;j"jj}j9tuRZ8- 2Mm!ANΦnAFJoW_VmCCkoč{1T|4U65}e&`k6eNokgheidy򣕪e k) 666sGN1ۍ9P8x9=CzL#cݩיù߅eЕu؍-m,و9<<<^zJxf{nz)zzzk{Wx4|}gp.`%P6 p7H'*WMp{>+d814*t>L(BFrxqAIDS$25nmTX 11E1_bcq.qwig^'*$%~N2JO';'PL򤦦ɥ3eM}ݧWӏ+x"|AC CC'\ s9}Q_cc#\?0y1A=3<6Y; .]zu~fhc=sLssF Ot'<{BEK_U-VV*V_K.[ּ_[?81)Yy-ޭܭomfNygN??x+[{mo#{>ާޏYs/n_F{{8[ַ#^pHSgluO{Dөia?{6LG @JpBQ1XO\ BEKf@EQJ9@OCGp.".N)ťm!#/( +)&/),m-c *'-ϯH*(QYT}֫ޠQk/moh2`Z~J A!aFQV16q6 Iɚ) i稠+xrą̲\yؼO/(8ůT]kœ%-e1׵+*)+xS5SSS]WwӧަAQIK3e zgǯ'];n^>~Cʇ;F&~'}?520]峋3)$ž\~z{qٗ/$^Z [_i[}N4z;?' kWøoUG~2;]}27Oua$<aEZg,[!\&rSSPQKѐ|kaeea3fZn!ʉ]k%%+!$B-+:&V..a .Sj^Q&UNNL+pWR ʡu` 5M2Z :4zm 4ڍMLLYMFͯYZjZ1X}v@;Xlp]w:[a)Eا_Q` !p/h&5RhhETuķȥ蒘X8xāI).ji'7d\4ϒʦ;y5R|e+l£owT^-*OYX}ýʥڱƾ֮Mm]C-fж] wGz r 3>;{hڃI)i!.ܚznDgKϞyeҸr[wߓ}p>X,öE9{ej]9bqqx 6hOBJ2CAAvLGN)NCUOe+%tv 0L,,Yﰅ prq1r-qy+!BB".KbW$H$JfJHäeeew cJJoKTLTj|k%Z$Zڙ:8P^fXoh,md4֜d+kjufCӞ3a*NXΕ.R'ng==y{E{+ |}D$A$谙HȍѸxĶdƴsg\p6S.,k'{,Fn3y /ynA³Wu^VR2VRVTrݿ¶RD{5y kvݫ Í}M]ڛ[[ZZ[ wtܾ}{gwoݡèJc&'M b @ 0 b{dX?  rKNRP(S @%P4kxxyr Cn A4HEwX@P4-@{H0<1y_ ۄ0*3& C ayb:aݰC"l vx8 . kMp/>"x5 |BP"EYh"Qh@t#O} dB " Cz#DA#[o(ŋEQ~xT.: 5GmBVFӣhS:.A7[<&)4a0 m/,5z`c~cNjSYpb\+n<ρǛ})b|;~A 4 HB0LxA8 bIIIIH o}LK%!$s#K"+##[";$$'7%$%o""GЦHؤSrRjRSܢBQRSQPPRSSPKQPPQRixhih.ܦy,3:'mm+#']6]"Oz6zmz=+ sh q]F*FEFwlی/`LLLL5LYuCKGwYhXXX YXvX)YUX}Y YﱾgfSg `+fcggb׃}/5GG 'SӋ>>+1W-Xn9nkG<<<xzx]#U=G_ H @X&(#+x]p^)$/$T-$LV%.B#b$&#QKA艘XX+q q4~u$%$J%u$%{%?K JyJUH=6 }_LL̎,l\ܤY~@BmOŠMxH6666GZkvvv}{ 3Wl9J;f8>suqrfppt!uqstEں6U?[~v]5BOem/ewWw|T}|v}5}K}?Ub](ƂYcCC2BBB Ý{#"B"EE\R*mC(V 6+v;N'.?=!5a=Q=* L:t?39=y+E7!:&Vtoede,]PP͒͜*:Ȟ)9uϝ(~iW%KgU/7l^1]V]թ"k8z׊{KJKK}J4ʙʳʏ{\_Phd̩y*ݪjTMTZډ:ƛ 7sn_khkmllbjt v+Nc\VKopkUM[N;õm;:[Pc{|zz{ +߹+r~}lzn(}^ܽ._ڍ>37|`tB}ޤTߴtCݏݙ3+3Xq\Ђ'?}h8%ǥ߽xe_R+d+ELկ_ɬ k?ڰxMķE6x73!~fIӣ}azp[_G71cqo''˧df &Z_c7w6h@6 11yaq aq1{̓cJm`4?Ϙ)Ħ."w'acd? pHYs   IDATxyXT, & J (*jaP#5E|,).^[i₥DY^1E 2̜\6̙g9fxa@!<&B!(!GAF= 2BQBx{dޣ #!(!U}6lX'M.d|GڬBXZYdd$rssq6BCaҤIZG!UIRx{{###ĉ@pp0=_~½{Z7n+(-->|80m4hS.!Di=G6i$߿X,ƢE_~jɭGCCCr9jjj0rHɓD:uBLXz-ǣ vvvݻQ__d1* mw{쁇-ZXr%\]]QWWm&GVV<<<`aaCB ʕ+?>JKKWWǶREEE(((hRDyy9ݵ-bB2w}OOOL82 qqq!JbΝm.9Hmmm-߿Cpp0> ]tEɄ|Mطo"##<饗 JVwߡj!//w^aÆ!''߇D"ѣG@ !&D'A XYYׯcРAqfΚ5 3g΄7>{ܹs7\B#׮]b1!H`ee1P(xgZ-_^^RDBxJAF?5iN&Ia!44A׉~QAR`qP(d\ `(tLN\T*ei#вǥ .HPdBrD(tiT*ұcGK#RUUHHlQ5NT*(J(J4666.@\ fH$bD(tpRd r҈544!~6ݣ ӱFfG OzkKs!CAC-C \F ٤?QX0 +Gf^ ! oGBm%͑\BnjCٽ{ <5_ 2ͷdE.} #Ym۶ :t_U zK\1\b4?΂l*A/J%4AF ;{,޽ azΞ=Ez.Jw\.ǭ[p=Ѳiiir^vVXQ˞ + ۴iM^CC6nEzV #F|}}Q\\ܮe7l؀륮rm( AP(k.R BaRt零Ő www\pի @ZZeLky!g jaP(lul MRa…@=j˗ y&{'[o{xtR466bȐ!z[ظq#Я_?UTT#FcǎׯN8w%=%%%;v,:vv=R,Xݻ7ڵ/Ybbb3Դy^r9f;wse[h󑛛k"** III(((#GDs^{ yyy AII ,,, Jaz|xWagg{b(,,lUgpp0^|E\r3gرcٳ_EDD"##[nATȑ#شig ={X;ֶ]oRxwԩS???xIƍ9nnnaСRRR J1rH>c!22prrb5kv܉j@jj*ѣGBݺukUÇq$&& ^xlݺ}LEE,Yɓ'~OMMEqq1֮] xzz>ʕ+Bee%VSSoMnp9TVV  BPPmmlly3g`ܸqm^@~f5sylׯ_,--qf%,,oɒ%m̙33f hfh_K%=h!p18::LC0 \w0 Ǐ7kcHHH@~PUUQF=>'''6;FWAAj_bj}l;w`˖-۷/gn9r$>31ϟoj%w}/f{&L@EEOYf[!!!Ix瑝dggc͚5P(㾉 317n܀3PSS;v"//={}]vGYnRSSFZi9s&JJJ0mڴ6(,,3bbbHMMŬY$$$ ((H?|tNNNO?@,DvqdQuuuQ]]JܻwF\޽ kkkڶ{qt}Ztڵ| I `޽ppp@N`oo[[[bK$](E.Bp>!GAF= 2BQBx{dޣ ӑgny̋ݣ0=hbdESxX[!&.P3Smٯ'Ӝmh}t b4g? 2kك*TWWuuuhhh@cc#J%6GB!b1,,,`eetЁ=`5o3#CACMX,%P(ؓBH$6 2мOѡCX[[ʊ9\3k:$AA#-4C DKKKX[[!]Pg6#clo["ʪYYZZB"4^\~QX H$5nmm B+GX,f{e0a{e0QP`2 )0SP!Ԅ΁6 35$I2 3 ӱa2j>---)þб`{bbDAC780Dl8iTD";TTlP~ӞX~ 3 !͡n;[,7 !FAYsZnKFA?d:y6}j93aZ(C7 3M[jל60 2kD͂L\}[ӀjXM?(΢G-{\mLԲ:/Q7r[EA_m7( O= 2BQBx{dޣ #!h;2BpmTVV ~~~mi…  T*]"$$=呇 #;v ÇѣQZZ˗/ɓ(++CLL f̘iӦRI 8!鉜 :⣏>ÇqqJ04GFݻwt߿N:R0d-\SNk֮/X"8<\!y 2bN<\\t鉖7or9BCCqiB4GFڠA0gL<;w.푐\ İ/OVVVrSY'OĪUtXyR##f+((ÛoU;L 8PGՑ'A=2bN>rDDDhVn7୷Buu#Ozd,M8￯6gΜ @͛7M>d씕A*:kR۶mȑ#u.y<Z}vDDD4۶mQ[[ӶɣQ/// @/O2HLLK5 2bVd2x'qmHR:u }zВm۶aڴiz]>S̚5K!C=2b6ѵkWERâE0i$Pt ߿u9&dj899~43g( |\bGf"j5%LWWW 1HLLǑu)&N#qid2ܼyuuuRD=Я_?L4 !!!H$\̩LL02dkk8p }YK5Zjb֭())A@@0d666ĥK/ %%ׯ_'|wy޽{cΝ㺔Zt)򐝝 Hu9EAf.^Dvch5d2,YB_5<==Xz* 2Ky$a0~x466ѣ\[4Gfd](1իWw' 19995jq)=Ul2331~xx,@LܼyO^__;v $$NNNzqzrmf錃l2Fgm۷>}ZgmÇ3二v￙ѣG3 b._66626mb\\\&33? Tq Zfl8::2K,a***~qqqavڥIee%ckkq]T.]hȑ#LCC{ii)_2nnnLHHsy5.dt3tPߟ_tڕʌ;2Zee%b fȐ!LNOOOc:w̄3 %0HJJBRR0k,øqO?wYM2CŌ3.Ek@ ;}dVVV(rٳ]v5x ;v@BBΜ9gy'JGGG\p-}ki@YYYq)~m눈J}A!ff( @T"66>g$%%𓕕cr]10Z۷{{{qzҖnݺ___dffߟrtB*b֭b@#ӣ3O⺔vSpttD~~>uu9#BJJ Lt1P\\̫cd2S1 gaҥA`` H$š5kpB466r]N D(ȞZܹssN$ѫW/lذRڅ͑=\(###\7>|8._lG(**/RGNxW! m!GBBץr81o'OӁΝ;cui֭6|LT"::ʂ^gN兴4nnn(**^EǤ{dCHHq) 1 rd49Bd?K/a$Z۷u=[la%y(Z۷111X~=g;BCCqFTT^Jʐ6T1 xl߾Yf̘;;;^ZmO8AAA;w&dݻ}͍QBx& !GAF= 2BQBx{dޣ #!(!GAF= 2BQBx{dޣ #!(!rJ6/ݻ7%#bR)\\\pBC${YJJ?>i&B͛7套1q%%%osΘ7o.^خeE"$ $ D"B!{qq1WFRR&N={bժUHKK?___l_}|||uI2x{{{{Ō5ӣGfDGGd2gabccN:1~-o>F 0 bd2Ì=adݙC1///f׮]Z?GO0 Zfu~olll?T*T*q5,] ,h?3aL<àA0 ~m1{l30o<޽Z  χ]~_,u}|nݠP(Y[[SN={6O9D1IDATnݺ---!Jb]QQ~7$''r9z9 2]| BJ={6%1qD@cccӠ~BL|}}qFTTT %%E!^Æ CFFۋ3gVXu- ![[[|';v,{9j`͚5Zvd0 ]ٳNڤ #͑Bx{dޣ #!(!GAF= 2BQBx{d?n IENDB`reactive-banana-1.3.2.0/doc/frp-event.png0000644000000000000000000003554007346545000016254 0ustar0000000000000000PNG  IHDR2;u'yiCCPICC ProfilehPTMϙ9s9$Qr9#"IDD$ $H$ 1DDAQD {ڭڭs歮9-$$FAalvlD@ssQ7333DX~B fPLyCq>yAq;ЩDGDQP̀G{ ԕj ЄbWg^TPšgi=00zM~ 󹇄AcAsb77?k۲{c^@847jdjg0}/@9  0*඄Rp_'pCKUVTH Tq @@ #l  (J*hz!`Vpp^/@,,"Pe@%P 4-m#`X ?S @ dA!P@]@0 s`6X- 3" n FQXa|0 Lfsyat%X) {v`_s*p- OK7]c 'Ep# "GT"k}$$Gr %ZHk72,G" 7#ńEilPDT>ՋzZGqh$ZGg+]i(`0ޘdL3Y|Xe 6{{ۇ]8V< p_D<^og ('AH%: DK$#V$L$$$$$$K$G26ѤH{H~''S s$K"A6JM#%$! #OAN!GBq9%H)@iEDHJʆ*5Zڃz 1M"M32-V6vF7E^ޕ  B .  ~0 322N2berg*bf,\EŃ41k!/[]]vvSTo8h888nqprjpFp|΅R zʍV^AT,"yxx+yU  ~rz t,,!+\)L()'r[dGMN詘XXغ8xD-lW%R:RRR?C[xT˼e=#["\FZSy*y+BEjbN77x|Z>+K+* TU.,26~QWKSVTwTS!HFM摖EڡC:x[:/jyzz1z4w VuچEFrFFLLMMMCLhSZPXx[ XRXXYQYY [ZY0D<崍}b'hnl/mgPəGcSӄ3ss)K.\u]k\Oθ:zv]=}Cã^/o1<=C&_?ntM %^ K`RJr`P0ǰpߑNQQQ*'11C,Iq*qq'C , +ʉIgcȦZvQ͝;wtfddg\пАΜz]=uQb]23oϥKou//\,/*xJs!0p,:Q]T,W\Zĩd4tL[_>s]_+l*z+++nhިTWVWV9S3TQ{vΨ&͘j ؆FƲ&ɣiȭ[?Z[.iimv>ۑqxh@gA.;bwJn^Bodjn_{?Czǻvw \4ZK?8<9"5Rux?Q1qx%)i銇?rx45#70K;{a9ݹyB'O>UzڲȺ |͒s/X^俄|գe+\+Vq_{^Z3\ZX۠߸ nFnqz3Vm6v;];.;O qev/iGߏ?YW, ݗAW+Ծu |g~Gҏß?7~;=-4?Pi:">+J^e@ ЂHo# xBi "5:P 4@@t pRL u)P @k0b:xl!ς p<ia0aLf KeÊ`հ6哰E¹p5 _ }(!C!j3+D4DхxXB ~" HR/7=BPf(OT,*U|&9hS':]n@C?Ca&$㎉\Œb1X,/V k bob/_q8~k=mxV"7o pAp/ DRшO&6'H$$:$^$$$$ۤR~RR\Y}2r2I2kRA5r89/!y0e " &%Rw !36U U=w {7h4r4gihhВ*Ҏ1EU=;ϠC@P0#c..S"S *3 *ss E /V!Vg|ldz>[_`g`<r*:(ȃQie'W1_?@A`2D!a!o*W4f9D@%NOޢ5 I 3%I?%$%H~ j$-*{OFX&PE棬ll쾜\\ܡ||B¨"RQO1GqV\JX2rQp^ߪlyջjk\ИY%5MԶ֮ӉչKеѽ^OJ/IoJJYQ@ `ɐ0pcdeTeX8 I=SF#3fo%--B,-,]-;@+ jk-omll^ &qEM3ُ8P9x;!9v#ɱ wsnv]l\]AWf7[YY(w'NG'ר7wOςoK?I7JW?hx+L<2*&V^+:-y/>*"j6?\j|̕qq]~ l b9oԓʓ-[R0)gSSR#R O[?tt[`̈xzABLӬ3YaُsrrjV\t؟GإK =/^QRvg}aUWI}f~8xDb^Qis,QPynuJʼʏ7LoUUVWKT_Zc]]K[SNM4444bgD.7ܲL߼ҢRՊhjlݢNmG\m՝N.;6w7{tz!>+?vnO݃ CCB=.FLOL2Oܙ2f>7a#G>XͲf~zlxh{؂B'J=-_D,,>}n\y )/v^*eUչpkk-4Iۛfod5Vmmw ww+@ayWkyr/~oǎOt?79/&_0l5yHwtM[Qw7~xSgϓ_gm$iſ7?Qa:d1ր >߇@_qb2&!` x,/5? @dy@PT@st\> L /ꏃ CaLKTa0[;d LU 3N3pmO+! d{"!PE%9D!уBB!N!kB `dوDCEDdP(T* UBM^CƎG& 7G4#1`R0%4fsbD5l-1dqgjqøew<^o_Gc=A`M'\&f {Dek*4U*UcjnjSX4塵Mm}Fsˢۤ'W/`ɐ𚑄Q1q'?=S&S/;f:f=,Xy_R :%SkG׳?q(qqXDprrsr\R\\e\ 4r9dJ>=$N~V~k#2A``[!f!kBBo 19 mc,H%. #EBXWVbMINPr^(e uAjLVN> ه(,ANPOInG_OIBBGEQPNC%YXSeuʓ*xS+*K;j"jj}j9tuRZ8- 2Mm!ANΦnAFJoW_VmCCkoč{1T|4U65}e&`k6eNokgheidy򣕪e k) 666sGN1ۍ9P8x9=CzL#cݩיù߅eЕu؍-m,و9<<<^zJxf{nz)zzzk{Wx4|}gp.`%P6 p7H'*WMp{>+d814*t>L(BFrxqAIDS$25nmTX 11E1_bcq.qwig^'*$%~N2JO';'PL򤦦ɥ3eM}ݧWӏ+x"|AC CC'\ s9}Q_cc#\?0y1A=3<6Y; .]zu~fhc=sLssF Ot'<{BEK_U-VV*V_K.[ּ_[?81)Yy-ޭܭomfNygN??x+[{mo#{>ާޏYs/n_F{{8[ַ#^pHSgluO{Dөia?{6LG @JpBQ1XO\ BEKf@EQJ9@OCGp.".N)ťm!#/( +)&/),m-c *'-ϯH*(QYT}֫ޠQk/moh2`Z~J A!aFQV16q6 Iɚ) i稠+xrą̲\yؼO/(8ůT]kœ%-e1׵+*)+xS5SSS]WwӧަAQIK3e zgǯ'];n^>~Cʇ;F&~'}?520]峋3)$ž\~z{qٗ/$^Z [_i[}N4z;?' kWøoUG~2;]}27Oua$<aEZg,[!\&rSSPQKѐ|kaeea3fZn!ʉ]k%%+!$B-+:&V..a .Sj^Q&UNNL+pWR ʡu` 5M2Z :4zm 4ڍMLLYMFͯYZjZ1X}v@;Xlp]w:[a)Eا_Q` !p/h&5RhhETuķȥ蒘X8xāI).ji'7d\4ϒʦ;y5R|e+l£owT^-*OYX}ýʥڱƾ֮Mm]C-fж] wGz r 3>;{hڃI)i!.ܚznDgKϞyeҸr[wߓ}p>X,öE9{ej]9bqqx 6hOBJ2CAAvLGN)NCUOe+%tv 0L,,Yﰅ prq1r-qy+!BB".KbW$H$JfJHäeeew cJJoKTLTj|k%Z$Zڙ:8P^fXoh,md4֜d+kjufCӞ3a*NXΕ.R'ng==y{E{+ |}D$A$谙HȍѸxĶdƴsg\p6S.,k'{,Fn3y /ynA³Wu^VR2VRVTrݿ¶RD{5y kvݫ Í}M]ڛ[[ZZ[ wtܾ}{gwoݡèJc&'M b @ 0 b{dX?  rKNRP(S @%P4kxxyr Cn A4HEwX@P4-@{H0<1y_ ۄ0*3& C ayb:aݰC"l vx8 . kMp/>"x5 |BP"EYh"Qh@t#O} dB " Cz#DA#[o(ŋEQ~xT.: 5GmBVFӣhS:.A7[<&)4a0 m/,5z`c~cNjSYpb\+n<ρǛ})b|;~A 4 HB0LxA8 bIIIIH o}LK%!$s#K"+##[";$$'7%$%o""GЦHؤSrRjRSܢBQRSQPPRSSPKQPPQRixhih.ܦy,3:'mm+#']6]"Oz6zmz=+ sh q]F*FEFwlی/`LLLL5LYuCKGwYhXXX YXvX)YUX}Y YﱾgfSg `+fcggb׃}/5GG 'SӋ>>+1W-Xn9nkG<<<xzx]#U=G_ H @X&(#+x]p^)$/$T-$LV%.B#b$&#QKA艘XX+q q4~u$%$J%u$%{%?K JyJUH=6 }_LL̎,l\ܤY~@BmOŠMxH6666GZkvvv}{ 3Wl9J;f8>suqrfppt!uqstEں6U?[~v]5BOem/ewWw|T}|v}5}K}?Ub](ƂYcCC2BBB Ý{#"B"EE\R*mC(V 6+v;N'.?=!5a=Q=* L:t?39=y+E7!:&Vtoede,]PP͒͜*:Ȟ)9uϝ(~iW%KgU/7l^1]V]թ"k8z׊{KJKK}J4ʙʳʏ{\_Phd̩y*ݪjTMTZډ:ƛ 7sn_khkmllbjt v+Nc\VKopkUM[N;õm;:[Pc{|zz{ +߹+r~}lzn(}^ܽ._ڍ>37|`tB}ޤTߴtCݏݙ3+3Xq\Ђ'?}h8%ǥ߽xe_R+d+ELկ_ɬ k?ڰxMķE6x73!~fIӣ}azp[_G71cqo''˧df &Z_c7w6h@6 11yaq aq1{̓cJm`4?Ϙ)Ħ."w'acd? pHYs  IDATxylݖBERJ$ E\!֣BLD!* @+64 DX@ v5?ow[~Mdҽfkwξ'ɲ,H`hW(\ 2" #"1ȈHx 2" #"1ȈHx 2"V5jTۧLSrW_}Z8E lҥKmnwƔ)S®Qsdiii߿?vܩO?j"++ xѵkWL:W\it,>}Z#ܹsGFJJ f̘7nS]"2ȦLoFb„ X,Xt).\CcՍD}}}ܸqx'?l6Dd@p"77555Ν;uVa3f |>fXt)>@Νrn@nݺaȐ!صkRSSaZIpq,ZΝCǎѹs{<8q;EUUvn@2;Э[7L<$oߏ4lڴ _u+ڵkxdeeH}\MM 2&M4 %%%ؾ};ߏ;vYSRRpAmG2\v 6 >|8$IҢDd Y0|pv :0qD:u 4hJAΟ?sA?Ƒ#Gb޼y֭ _~ׯעDd0ދ};vDVVƎcwս]vaݺuM ȋxvcj+󡰰BO Zb):U?~gώXb^[dvjtbdj46EC=Gݾb dG͜9%%%CJJ |A\t n8s .^rzsȲUV!##ݻwQVVMbxXъ7nhr^޽{Q\\b\t Viii/O?ţ> Xt)*++Q^^UVaԩps˗رcسg|8zǃ5k֠ڵCff&RRRPVVgy7d2!33@vgXǏnnܸz {Űa좑*Avq$It(Mw}cdbrqqq#GToZ3gΞ=3fSXXgϞݻ7^xf=;wF~гgO,[3l0,YcƌAzz:^y=ٟxEu]KI sW r먮ƕ+W0qD˗/pM6ŋxХKfsU$&&ND$a۶mh׮6m 66111X,L#;v1{n{mqydl|k "1ȈHx 2" #"1ȈHx 2(EYQVia: 1Y< ƚ |&:i/pqYd~(6 4IYe\ 4Lc-1 Պ"먭B}}=<^oןL&X,XVv".. tCVQˌ P`RiY,nvL&un.(llp8nWFBƔfCLL bn[]h3c$IjkfnYLL l6[Pcebi,0l6Ҹ2rVlC.Z,UYll*SŒ]K14bVU]e\ )v \8ffk4V0Lcatwx<K*5VXV% ,0j8)c*fYj|>5ȔI M*-~dR8Ni*.H+l vUUU8qzd\.8# 97777ZۈbسgΝ;k׮a0zС#|yDbREEEpJJJpذa!# (--ŸqPZZN:ӦMCyy9~icdp:СCo "Sp"2|Lc!2Vd>Z!2VdDd\kID #"1ȈHx 2" #"1ȈHx 2"n>4p9s&*D;bɒ%ʂln>>h"aڵۍϣw޺vEFdpgϞEII &Mmb?lffldR9s+WO>ɓѳgO|زe A1׭[`ϵ%(rDBBB @,p8=z+W]֬K̙3r>}dY IIIM۷˒$rEEnT##GeyAq;ЩDGDQP̀G{ ԕj ЄbWg^TPšgi=00zM~ 󹇄AcAsb77?k۲{c^@847jdjg0}/@9  0*඄Rp_'pCKUVTH Tq @@ #l  (J*hz!`Vpp^/@,,"Pe@%P 4-m#`X ?S @ dA!P@]@0 s`6X- 3" n FQXa|0 Lfsyat%X) {v`_s*p- OK7]c 'Ep# "GT"k}$$Gr %ZHk72,G" 7#ńEilPDT>ՋzZGqh$ZGg+]i(`0ޘdL3Y|Xe 6{{ۇ]8V< p_D<^og ('AH%: DK$#V$L$$$$$$K$G26ѤH{H~''S s$K"A6JM#%$! #OAN!GBq9%H)@iEDHJʆ*5Zڃz 1M"M32-V6vF7E^ޕ  B .  ~0 322N2berg*bf,\EŃ41k!/[]]vvSTo8h888nqprjpFp|΅R zʍV^AT,"yxx+yU  ~rz t,,!+\)L()'r[dGMN詘XXغ8xD-lW%R:RRR?C[xT˼e=#["\FZSy*y+BEjbN77x|Z>+K+* TU.,26~QWKSVTwTS!HFM摖EڡC:x[:/jyzz1z4w VuچEFrFFLLMMMCLhSZPXx[ XRXXYQYY [ZY0D<崍}b'hnl/mgPəGcSӄ3ss)K.\u]k\Oθ:zv]=}Cã^/o1<=C&_?ntM %^ K`RJr`P0ǰpߑNQQQ*'11C,Iq*qq'C , +ʉIgcȦZvQ͝;wtfddg\пАΜz]=uQb]23oϥKou//\,/*xJs!0p,:Q]T,W\Zĩd4tL[_>s]_+l*z+++nhިTWVWV9S3TQ{vΨ&͘j ؆FƲ&ɣiȭ[?Z[.iimv>ۑqxh@gA.;bwJn^Bodjn_{?Czǻvw \4ZK?8<9"5Rux?Q1qx%)i銇?rx45#70K;{a9ݹyB'O>UzڲȺ |͒s/X^俄|գe+\+Vq_{^Z3\ZX۠߸ nFnqz3Vm6v;];.;O qev/iGߏ?YW, ݗAW+Ծu |g~Gҏß?7~;=-4?Pi:">+J^e@ ЂHo# xBi "5:P 4@@t pRL u)P @k0b:xl!ς p<ia0aLf KeÊ`հ6哰E¹p5 _ }(!C!j3+D4DхxXB ~" HR/7=BPf(OT,*U|&9hS':]n@C?Ca&$㎉\Œb1X,/V k bob/_q8~k=mxV"7o pAp/ DRшO&6'H$$:$^$$$$ۤR~RR\Y}2r2I2kRA5r89/!y0e " &%Rw !36U U=w {7h4r4gihhВ*Ҏ1EU=;ϠC@P0#c..S"S *3 *ss E /V!Vg|ldz>[_`g`<r*:(ȃQie'W1_?@A`2D!a!o*W4f9D@%NOޢ5 I 3%I?%$%H~ j$-*{OFX&PE棬ll쾜\\ܡ||B¨"RQO1GqV\JX2rQp^ߪlyջjk\ИY%5MԶ֮ӉչKеѽ^OJ/IoJJYQ@ `ɐ0pcdeTeX8 I=SF#3fo%--B,-,]-;@+ jk-omll^ &qEM3ُ8P9x;!9v#ɱ wsnv]l\]AWf7[YY(w'NG'ר7wOςoK?I7JW?hx+L<2*&V^+:-y/>*"j6?\j|̕qq]~ l b9oԓʓ-[R0)gSSR#R O[?tt[`̈xzABLӬ3YaُsrrjV\t؟GإK =/^QRvg}aUWI}f~8xDb^Qis,QPynuJʼʏ7LoUUVWKT_Zc]]K[SNM4444bgD.7ܲL߼ҢRՊhjlݢNmG\m՝N.;6w7{tz!>+?vnO݃ CCB=.FLOL2Oܙ2f>7a#G>XͲf~zlxh{؂B'J=-_D,,>}n\y )/v^*eUչpkk-4Iۛfod5Vmmw ww+@ayWkyr/~oǎOt?79/&_0l5yHwtM[Qw7~xSgϓ_gm$iſ7?Qa:d1ր >߇@_qb2&!` x,/5? @dy@PT@st\> L /ꏃ CaLKTa0[;d LU 3N3pmO+! d{"!PE%9D!уBB!N!kB `dوDCEDdP(T* UBM^CƎG& 7G4#1`R0%4fsbD5l-1dqgjqøew<^o_Gc=A`M'\&f {Dek*4U*UcjnjSX4塵Mm}Fsˢۤ'W/`ɐ𚑄Q1q'?=S&S/;f:f=,Xy_R :%SkG׳?q(qqXDprrsr\R\\e\ 4r9dJ>=$N~V~k#2A``[!f!kBBo 19 mc,H%. #EBXWVbMINPr^(e uAjLVN> ه(,ANPOInG_OIBBGEQPNC%YXSeuʓ*xS+*K;j"jj}j9tuRZ8- 2Mm!ANΦnAFJoW_VmCCkoč{1T|4U65}e&`k6eNokgheidy򣕪e k) 666sGN1ۍ9P8x9=CzL#cݩיù߅eЕu؍-m,و9<<<^zJxf{nz)zzzk{Wx4|}gp.`%P6 p7H'*WMp{>+d814*t>L(BFrxqAIDS$25nmTX 11E1_bcq.qwig^'*$%~N2JO';'PL򤦦ɥ3eM}ݧWӏ+x"|AC CC'\ s9}Q_cc#\?0y1A=3<6Y; .]zu~fhc=sLssF Ot'<{BEK_U-VV*V_K.[ּ_[?81)Yy-ޭܭomfNygN??x+[{mo#{>ާޏYs/n_F{{8[ַ#^pHSgluO{Dөia?{6LG @JpBQ1XO\ BEKf@EQJ9@OCGp.".N)ťm!#/( +)&/),m-c *'-ϯH*(QYT}֫ޠQk/moh2`Z~J A!aFQV16q6 Iɚ) i稠+xrą̲\yؼO/(8ůT]kœ%-e1׵+*)+xS5SSS]WwӧަAQIK3e zgǯ'];n^>~Cʇ;F&~'}?520]峋3)$ž\~z{qٗ/$^Z [_i[}N4z;?' kWøoUG~2;]}27Oua$<aEZg,[!\&rSSPQKѐ|kaeea3fZn!ʉ]k%%+!$B-+:&V..a .Sj^Q&UNNL+pWR ʡu` 5M2Z :4zm 4ڍMLLYMFͯYZjZ1X}v@;Xlp]w:[a)Eا_Q` !p/h&5RhhETuķȥ蒘X8xāI).ji'7d\4ϒʦ;y5R|e+l£owT^-*OYX}ýʥڱƾ֮Mm]C-fж] wGz r 3>;{hڃI)i!.ܚznDgKϞyeҸr[wߓ}p>X,öE9{ej]9bqqx 6hOBJ2CAAvLGN)NCUOe+%tv 0L,,Yﰅ prq1r-qy+!BB".KbW$H$JfJHäeeew cJJoKTLTj|k%Z$Zڙ:8P^fXoh,md4֜d+kjufCӞ3a*NXΕ.R'ng==y{E{+ |}D$A$谙HȍѸxĶdƴsg\p6S.,k'{,Fn3y /ynA³Wu^VR2VRVTrݿ¶RD{5y kvݫ Í}M]ڛ[[ZZ[ wtܾ}{gwoݡèJc&'M b @ 0 b{dX?  rKNRP(S @%P4kxxyr Cn A4HEwX@P4-@{H0<1y_ ۄ0*3& C ayb:aݰC"l vx8 . kMp/>"x5 |BP"EYh"Qh@t#O} dB " Cz#DA#[o(ŋEQ~xT.: 5GmBVFӣhS:.A7[<&)4a0 m/,5z`c~cNjSYpb\+n<ρǛ})b|;~A 4 HB0LxA8 bIIIIH o}LK%!$s#K"+##[";$$'7%$%o""GЦHؤSrRjRSܢBQRSQPPRSSPKQPPQRixhih.ܦy,3:'mm+#']6]"Oz6zmz=+ sh q]F*FEFwlی/`LLLL5LYuCKGwYhXXX YXvX)YUX}Y YﱾgfSg `+fcggb׃}/5GG 'SӋ>>+1W-Xn9nkG<<<xzx]#U=G_ H @X&(#+x]p^)$/$T-$LV%.B#b$&#QKA艘XX+q q4~u$%$J%u$%{%?K JyJUH=6 }_LL̎,l\ܤY~@BmOŠMxH6666GZkvvv}{ 3Wl9J;f8>suqrfppt!uqstEں6U?[~v]5BOem/ewWw|T}|v}5}K}?Ub](ƂYcCC2BBB Ý{#"B"EE\R*mC(V 6+v;N'.?=!5a=Q=* L:t?39=y+E7!:&Vtoede,]PP͒͜*:Ȟ)9uϝ(~iW%KgU/7l^1]V]թ"k8z׊{KJKK}J4ʙʳʏ{\_Phd̩y*ݪjTMTZډ:ƛ 7sn_khkmllbjt v+Nc\VKopkUM[N;õm;:[Pc{|zz{ +߹+r~}lzn(}^ܽ._ڍ>37|`tB}ޤTߴtCݏݙ3+3Xq\Ђ'?}h8%ǥ߽xe_R+d+ELկ_ɬ k?ڰxMķE6x73!~fIӣ}azp[_G71cqo''˧df &Z_c7w6h@6 11yaq aq1{̓cJm`4?Ϙ)Ħ."w'acd? pHYs   IDATx{\Tu0p,@@@mVdfO^U@WlfY[Q芷&" (rg{3\T35a̜0s~sJ!@DDDFi0􉈈CJ0􉈈CJ0􉈈CJ0􉈈CJ0􉈈4666-JhT l3 Bp*JBͰfp>`Y >`Y >`Y >`Y  ܺu4{{{nZ/;;AMak˯#BٳvO h ZOMMZ͛7L?p\]]QVVV~gtԩ!/M&]ooo >ƪUusrr0ṡ~T7 `dddذaC&5o&Zcĉ1y{>oXdIcbX2зo_XGADD fQmW^ҥ 8ٳgۇ7@MzEEEضmC7@)))*]k.<u~qz M0k֬ANNڴito}vk,e8y$TnFzz:tpe}&L}z8q"nܸ'#FѣGk<߯k֬A\\3g΄y$%%5\r BBBgyׯ_s/]???:t?,u[2̙33f ʮ 8pӧȑ#Xz50h Ν;$!p):u 5//}A^^BCC SN!33kfff65iu=<(O?FÇ#!!< ڵkɓ'#//<k׮ɷ ,@ZZ~iaڴi(,,l7efBٳ'0`dggiWc͚58|0郧z  ॗ^?bccԴk.,֮] q0``ѢEHMMũSGaҤI㭷ŋk֬?Gyy9V^իWc])^gb̘1}QڲeK}QQQX~=°qFKpssCZZ***M@^/ߞ={:߇V''&yMj::t@>}h4 2* /_Ƃ ooo}}}}8p XYTTQFa sRݟYB?,, K.ѣGh0p@F?o!DT*UMh4\pAf180 =z@bbҥԩSxb;wi}*<< ǏǑ#GgL0@ {0ػwoc[?v-O:t(?;w@"!!?~+#F{/um~Gb޼y5^;;;:|Iף@宺On{,..ƍ1w܇~nccUO׿U)))Yf;w"22RODEEUOOO^^^WO=ZYF!đ#Gիpuu+W4W5'N⣏>~///1hР:"^?_귫>&"//O 4HN:~AQ٧{n6lGu wwwѷo_Ѷm[QRRz ܄8ܧojĈ|X;@+C3~婁DΝyyyK.bGbժUK:tJƍZݺu]v؟ŋ ѫW//?h7w;wݻwC 999[.-[LhZ/|}}o!?Gj|||=zߪԴh"-z-:u$bbb}]V {{,P Qaƍprr V1h۶m痕h۶mnPW |}}4ŋѥKeeeIܺu pvv~疖_E```1dggBddd(((VѭW\\ NGysssnݺA6Z]q\\\f~@vi{WHϟdz>WB3+//G^^^Kk3=[ KR&siIߥ˗#77}YЗvZ.xc"" 7h zCgZ.Lu3OKDDd%DDDVODDd%DDDVODDd%DDDVODDd%xpPT-?&saa,̃Y n'"" }"""+'"" }"""+'"" }"""+x觧ݻJAD-^Dž .ER4KKKѹsg,YD28qwǏ+] Qh۷غu+ Q ~zj_^RZ$EC?66EEEBJBD\aa! 7 .Q,W\?3J!`ݰ<]F]Q,+o!9|!fN2T(*\QˣX(++ok4l߾]rKL|2222eR$O>*ӊ˝j_h4Vf4qF*"j9/#G@RAAJJJp6uIDԌT*888Ti3z=t:xvpUE7n܈f͚%bQ 8s mF߾},QdMJ*Q ?oڴ 3l2d(l3OQQm-Y>4k7Y z5o?QDTFQ!2  FyD<1VRK^QQ޽{cر(**^GEEDCB-WTT@ZjcǢ@~g5_ }"Ia-v  //zOԌq=&Pw9~Mz= z3f 55۶m#<[[*ؘ}p c5#k֜e/N;w\֨(:u [l4 `kk Z ZmgAT }Fb:z?NөPf})ѧO5꫈Ƕm ;;Z0.}l35)MwwV}_$ t:t:Cu ضmڵkWlll D b5З-|V°uVO,>}Mhɒ%Cxx8n݊N:8?rD^}n…ppp@xx8lقnݺ8?2Df&KGKKK.IDEEAbĉC=j}1̬z_NCYYʔ.̘1vvvx ^~e;0`Zjggg888@BV9>XzA222 /_~AII<...8|0z`-Y;曘6mzgggsκJII^}UF 8ݻw.ܸUBU?`Peڵ /2?SN9k?xe5=ZӥcǎȨ@[n'P?Ӳ5lق۷oCbuիW/\p׿l2\\\> ((H*v&=k?Fk|ԕUZ/W\A`` |.hӦ RRRϴlf c~P9:=,,L~~~PT6Gt/HMMɓwrrO?K.q~=%mmmayפƍ3Ǭ-vB~~>Ν/񈏏2Џ,|Oo`񁭭-4 j|Bj_-[WƷ~ WWWKk̲͛7@ǎ# ,,O۷QRR4Ahh(ڶm upuuEVЪU+899A!`kk+o kh3Yw٫W\ɂHHʻݽ{WVRR*Q4PRm;wuy]d 6l؀PxzzUVpqqzjCf՟oo$RFޜjaooN!j5Zm(4 I׵Y`mۆC^wvvcf|"2>AFĦjaggF_բ\VC#z5"<<nnnpvvwttܷov'jZ }"33occF;;;9إhZD<pRTxWpQL4 prr...4_Vxj]'j$f}_+Wh4r7Я~v@N'h4b1u*kpuu7ګ>p#C@!Rt (hz%RK' Ņ 0sLyPV/mDC̤0Bk48ᰴM`ooD(s̑7Kwrr_'jQ#0=t$kJ/ Go߾rK[-GGG899yl3ꏡOH7 _}^P>kR𗗗1V i)3D DD}R?=~|4RxKnB]t挡OHʘPkK}i4@:F:N"`G x1ҵt>Q'jd5 uG@J`0T9@?VPvM쥓0>QW6`~{`)ХMgc5O }"_=[LnQa߼y3gggL:ÇZit~2M%`:HB[12݋7|?QfgΜ{ ,8z >Dփv'4=`S= 3˚+0sLӧ1h s̚TX}EE兤$!z(f }8;; sɓ'1}ts̚)%ի␝C"&&F鲈lg|2zk׮!%%5УG& OIDAT\|%%%R,_#F͛7ҧu 6 K.ԩSCh[|rJBt_fY_r%ƏЁODTҮMyIHHs]0x`DDD(i՝YvK.Uַo_$''?CP?ׯXzQsSQtQQQya߾}ѿj!zX }"jQf՟FQ'"" }"""+'"" }"""+'"" }"""+'"" }"""+'"" }"""+'"" }"""+'""f ~ cǎ5,* 3gT""&c/**—_~ &ɓes)] Q***///$%%)]Y~AAΝ;ooos̮Q!كӧ#==YYY۷o+QQի␝C"&&Fi6PRRFR%uLeggc޽2)j!k6C)  Eii) < ͛`ԒY@<صkhӦ "##Q^^1cƠ{VL"jR2rHU |(..ӧyf9Y W_}G㑔ш{HNNF6m.WBh8;;CVWy]''' < sVO 3gΞ= 777vvvJGD`sptt888`ժUpԒYU觤QTT#F 00{Q2"׾}{"""8~8,XtYd*w܉7o"$$7oٳgcǎ!//Odׯ͛7ѿ! a* G?U M6!""MR՟'jLVD ?ڼODDdDDDVODDd%DDDVODDd%DDDVODDd%DDDVODDd%Dxye˖iiiJIDڌӧk׮J%``,X_PHOOGaoodVm5Gk3t:~7tYpM,ؿo|(--}jhZhZjTxbdeeܹs0a֬Y;"44iii:t(n:yiiixiӦМooѣG~mFff&VXXn>CcǎXv-v؁.]'3gynذ?8qƚ=2bk;w.0efwRRJJJP\\ݻw#++ qE <sAll,^{5AAA5jVaz__ҥKqu̷?3_ի/ǟ'|'شiz),]_wڵkuV|ؾ}{ki}R`cck3^۷hݺ5̙_~fy ggg|GP Bff&BCCm۶ŕ+W?-Pヒ8::ko+|Yҵ @Ν;(..Ƈ~?={ļy0fu3&Mixꩧ ԩS}͛;wb„ zmCW_hf "i)))`0EEEXr%-[zmm۶P;;;t]:x"|||z=rssѮ]`M^~eFzŗ3K,[%YYYয়~Bdd$"""/b޽ R{HNN (//G```_[ЏQt#Kj\VZs~ZjÇc׮]w,5XJ,Y,J^ٳ"m5h4prr2g]6cŊ TTTxS­._0Kt!o;;;T*t K2tP|ᇸs<==q!̛7׮]ktˠ?3z={IҡCJœ9s>Ae+f͚iӦC2x`DFFCܹ3yfEj!]vEtt4ƏWWWEjYl^xh4ǟW˭[p%  for more detailed documentation and examples. . /Stability forecast./ This is a stable library, though minor API changes are still likely. It features an efficient, push-driven implementation and has seen some optimization work. . /API guide./ Start with the "Reactive.Banana" module. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3 License-file: LICENSE Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus Category: FRP Cabal-version: 1.18 Build-type: Simple Tested-with: GHC == 9.4.1 , GHC == 9.2.4 , GHC == 8.10.7 , GHC == 8.8.4 , GHC == 8.6.5 , GHC == 8.4.4 extra-source-files: CHANGELOG.md, doc/examples/*.hs extra-doc-files: doc/*.png Source-repository head type: git location: https://github.com/HeinrichApfelmus/reactive-banana subdir: reactive-banana/ Library default-language: Haskell98 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, vault == 0.3.*, unordered-containers >= 0.2.1.0 && < 0.3, hashable >= 1.1 && < 1.5, pqueue >= 1.0 && < 1.5, stm >= 2.5 && < 2.6, these >= 0.2 && < 1.2 exposed-modules: Control.Event.Handler, Reactive.Banana, Reactive.Banana.Combinators, Reactive.Banana.Frameworks, Reactive.Banana.Model, Reactive.Banana.Prim.Mid, Reactive.Banana.Prim.High.Cached, Reactive.Banana.Prim.Low.Graph, Reactive.Banana.Prim.Low.GraphGC, Reactive.Banana.Prim.Low.Ref other-modules: Control.Monad.Trans.ReaderWriterIO, Control.Monad.Trans.RWSIO, Reactive.Banana.Prim.Low.OrderedBag, Reactive.Banana.Prim.Low.GraphTraversal, Reactive.Banana.Prim.Mid.Combinators, Reactive.Banana.Prim.Mid.Compile, Reactive.Banana.Prim.Mid.Evaluation, Reactive.Banana.Prim.Mid.IO, Reactive.Banana.Prim.Mid.Plumbing, Reactive.Banana.Prim.Mid.Test, Reactive.Banana.Prim.Mid.Types, Reactive.Banana.Prim.High.Combinators, Reactive.Banana.Types ghc-options: -Wall -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-fields -Werror=partial-fields -Wno-name-shadowing Test-Suite unit default-language: Haskell98 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: reactive-banana-tests.hs other-modules: Reactive.Banana.Test.High.Combinators, Reactive.Banana.Test.High.Plumbing, Reactive.Banana.Test.High.Space, Reactive.Banana.Test.Mid.Space, Reactive.Banana.Test.Low.Gen, Reactive.Banana.Test.Low.Graph, Reactive.Banana.Test.Low.GraphGC build-depends: base >= 4.7 && < 5, containers, deepseq >= 1.4.3.0 && < 1.5, hashable, pqueue, reactive-banana, semigroups, transformers, tasty, tasty-hunit, tasty-quickcheck >= 0.10.1.2 && < 0.11, QuickCheck >= 2.10 && < 2.15, unordered-containers, vault, these Benchmark space default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends: base , reactive-banana , tasty-quickcheck , tasty , QuickCheck hs-source-dirs: test main-is: space.hs other-modules: Reactive.Banana.Test.Mid.Space , Reactive.Banana.Test.High.Space ghc-options: -rtsopts -eventlog Benchmark benchmark default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends: base , reactive-banana , containers , random , tasty , tasty-bench hs-source-dirs: benchmark main-is: Main.hs ghc-options: "-with-rtsopts=-A32m" reactive-banana-1.3.2.0/src/Control/Event/0000755000000000000000000000000007346545000016354 5ustar0000000000000000reactive-banana-1.3.2.0/src/Control/Event/Handler.hs0000644000000000000000000000667107346545000020277 0ustar0000000000000000module Control.Event.Handler ( -- * Synopsis -- | -- in the traditional imperative style. -- * Documentation Handler, AddHandler(..), newAddHandler, mapIO, filterIO, ) where import Control.Monad ((>=>), when) import Data.IORef import qualified Data.Map as Map import qualified Data.Unique {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} -- | An /event handler/ is a function that takes an -- /event value/ and performs some computation. type Handler a = a -> IO () -- | The type 'AddHandler' represents a facility for registering -- event handlers. These will be called whenever the event occurs. -- -- When registering an event handler, you will also be given an action -- that unregisters this handler again. -- -- > do unregisterMyHandler <- register addHandler myHandler -- newtype AddHandler a = AddHandler { register :: Handler a -> IO (IO ()) } {----------------------------------------------------------------------------- Combinators ------------------------------------------------------------------------------} instance Functor AddHandler where fmap f = mapIO (return . f) -- | Map the event value with an 'IO' action. mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b mapIO f e = AddHandler $ \h -> register e (f >=> h) -- | Filter event values that don't return 'True'. filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a filterIO f e = AddHandler $ \h -> register e $ \x -> f x >>= \b -> when b $ h x {----------------------------------------------------------------------------- Construction ------------------------------------------------------------------------------} -- | Build a facility to register and unregister event handlers. -- Also yields a function that takes an event handler and runs all the registered -- handlers. -- -- Example: -- -- > do -- > (addHandler, fire) <- newAddHandler -- > register addHandler putStrLn -- > fire "Hello!" newAddHandler :: IO (AddHandler a, Handler a) newAddHandler = do handlers <- newIORef Map.empty let register handler = do key <- Data.Unique.newUnique atomicModifyIORef_ handlers $ Map.insert key handler return $ atomicModifyIORef_ handlers $ Map.delete key runHandlers a = runAll a =<< readIORef handlers return (AddHandler register, runHandlers) atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ()) -- | A callback is a @a -> IO ()@ function. We define this newtype to provide -- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which -- allow us to write the efficient 'runAll' function. newtype Callback a = Callback { invoke :: a -> IO () } instance Semigroup (Callback a) where Callback f <> Callback g = Callback $ \a -> f a >> g a instance Monoid (Callback a) where mempty = Callback $ \_ -> return () -- This function can also be seen as -- -- runAll a fs = mapM_ ($ a) fs -- -- The reason we write this using 'foldMap' and 'Callback' is to produce code -- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237 -- for more info. runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO () runAll a fs = invoke (foldMap Callback fs) a reactive-banana-1.3.2.0/src/Control/Monad/Trans/0000755000000000000000000000000007346545000017420 5ustar0000000000000000reactive-banana-1.3.2.0/src/Control/Monad/Trans/RWSIO.hs0000644000000000000000000000542407346545000020664 0ustar0000000000000000module Control.Monad.Trans.RWSIO ( -- * Synopsis -- | An implementation of the reader/writer/state monad transformer -- using an 'IORef'. -- * Documentation RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put, ) where import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.IORef {----------------------------------------------------------------------------- Type and class instances ------------------------------------------------------------------------------} data Tuple r w s = Tuple !r !(IORef w) !(IORef s) newtype RWSIOT r w s m a = R { run :: Tuple r w s -> m a } instance Functor m => Functor (RWSIOT r w s m) where fmap = fmapR instance Applicative m => Applicative (RWSIOT r w s m) where pure = pureR (<*>) = apR instance Monad m => Monad (RWSIOT r w s m) where (>>=) = bindR instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR instance MonadIO m => MonadIO (RWSIOT r w s m) where liftIO = liftIOR instance MonadTrans (RWSIOT r w s) where lift = liftR {----------------------------------------------------------------------------- Functions ------------------------------------------------------------------------------} liftIOR :: MonadIO m => IO a -> RWSIOT r w s m a liftIOR m = R $ \_ -> liftIO m liftR :: m a -> RWSIOT r w s m a liftR m = R $ \_ -> m fmapR :: Functor m => (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b fmapR f m = R $ \x -> fmap f (run m x) bindR :: Monad m => RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b bindR m k = R $ \x -> run m x >>= \a -> run (k a) x mfixR :: MonadFix m => (a -> RWSIOT r w s m a) -> RWSIOT r w s m a mfixR f = R $ \x -> mfix (\a -> run (f a) x) pureR :: Applicative m => a -> RWSIOT r w s m a pureR a = R $ \_ -> pure a apR :: Applicative m => RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b apR f a = R $ \x -> run f x <*> run a x rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a rwsT f = do r <- ask s <- get (a,s,w) <- liftIOR $ f r s put s tell w return a runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w)) runRWSIOT m r s = do w' <- liftIO $ newIORef mempty s' <- liftIO $ newIORef s a <- run m (Tuple r w' s') s <- liftIO $ readIORef s' w <- liftIO $ readIORef w' return (a,s,w) tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m () tell w = R $ \(Tuple _ w' _) -> liftIO $ modifyIORef w' (`mappend` w) ask :: Monad m => RWSIOT r w s m r ask = R $ \(Tuple r _ _) -> return r get :: MonadIO m => RWSIOT r w s m s get = R $ \(Tuple _ _ s') -> liftIO $ readIORef s' put :: MonadIO m => s -> RWSIOT r w s m () put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s reactive-banana-1.3.2.0/src/Control/Monad/Trans/ReaderWriterIO.hs0000644000000000000000000000660107346545000022606 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Control.Monad.Trans.ReaderWriterIO ( -- * Synopsis -- | An implementation of the reader/writer monad transformer -- using an 'IORef' for the writer. -- * Documentation ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local, ) where import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.IORef {----------------------------------------------------------------------------- Type and class instances ------------------------------------------------------------------------------} newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a } instance Functor m => Functor (ReaderWriterIOT r w m) where fmap = fmapR instance Applicative m => Applicative (ReaderWriterIOT r w m) where pure = pureR (<*>) = apR instance Monad m => Monad (ReaderWriterIOT r w m) where (>>=) = bindR instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR instance MonadIO m => MonadIO (ReaderWriterIOT r w m) where liftIO = liftIOR instance MonadTrans (ReaderWriterIOT r w) where lift = liftR instance (Monad m, a ~ ()) => Semigroup (ReaderWriterIOT r w m a) where mx <> my = mx >> my instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where mempty = return () mappend = (<>) {----------------------------------------------------------------------------- Functions ------------------------------------------------------------------------------} liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m liftR :: m a -> ReaderWriterIOT r w m a liftR m = ReaderWriterIOT $ \_ _ -> m fmapR :: Functor m => (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y) bindR :: Monad m => ReaderWriterIOT r w m a -> (a -> ReaderWriterIOT r w m b) -> ReaderWriterIOT r w m b bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y mfixR :: MonadFix m => (a -> ReaderWriterIOT r w m a) -> ReaderWriterIOT r w m a mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y) pureR :: Applicative m => a -> ReaderWriterIOT r w m a pureR a = ReaderWriterIOT $ \_ _ -> pure a apR :: Applicative m => ReaderWriterIOT r w m (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y readerWriterIOT :: (MonadIO m, Monoid w) => (r -> IO (a, w)) -> ReaderWriterIOT r w m a readerWriterIOT f = do r <- ask (a,w) <- liftIOR $ f r tell w return a runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w) runReaderWriterIOT m r = do ref <- liftIO $ newIORef mempty a <- run m r ref w <- liftIO $ readIORef ref return (a,w) tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m () tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w) listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w) listen m = ReaderWriterIOT $ \r ref -> do a <- run m r ref w <- liftIO $ readIORef ref return (a,w) local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref ask :: Monad m => ReaderWriterIOT r w m r ask = ReaderWriterIOT $ \r _ -> return r reactive-banana-1.3.2.0/src/Reactive/0000755000000000000000000000000007346545000015415 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana.hs0000644000000000000000000000267207346545000017140 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana ( -- * Synopsis -- | Reactive-banana is a library for functional reactive programming (FRP). -- To use it, import this module: -- -- > import Reactive.Banana -- * Overview -- $intro -- * Exports module Reactive.Banana.Combinators, compile, ) where import Reactive.Banana.Combinators import Reactive.Banana.Frameworks {-$intro The module "Reactive.Banana.Combinators" collects the key types and concepts of FRP. You will spend most of your time with this module. The module "Reactive.Banana.Model" is /not/ used in practice. It contains an easy-to-understand model re-implementation of the FRP API. This is useful for learning FRP and for internal testing purposes. The module "Reactive.Banana.Frameworks" allows you to connect the FRP types and combinators to the outside world (IO). If you are /using/ an existing binding like reactive-banana-wx, then you probably won't need this module very often. On the other hand, if you are /writing/ a binding to an external library, then you will definitely need this. The module hierarchy at "Reactive.Banana.Prim" implements the efficient low-level FRP engine that powers the rest of the library. This is only useful if you want to implement your own FRP library. -}reactive-banana-1.3.2.0/src/Reactive/Banana/0000755000000000000000000000000007346545000016575 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana/Combinators.hs0000644000000000000000000003457507346545000021427 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE MultiParamTypeClasses #-} module Reactive.Banana.Combinators ( -- * Synopsis -- $synopsis -- * Core Combinators -- ** Event and Behavior Event, Behavior, interpret, -- ** First-order -- | This subsections lists the primitive first-order combinators for FRP. -- The 'Functor', 'Applicative' and 'Monoid' instances are also part of this, -- but they are documented at the types 'Event' and 'Behavior'. module Control.Applicative, module Data.Semigroup, never, unionWith, filterE, apply, -- ** Moment and accumulation Moment, MonadMoment(..), accumE, stepper, -- ** Recursion -- $recursion -- ** Higher-order valueB, valueBLater, observeE, switchE, switchB, -- * Derived Combinators -- ** Infix operators (<@>), (<@), (@>), -- ** Filtering filterJust, filterApply, whenE, split, once, -- ** Accumulation -- $Accumulation. unions, accumB, mapAccum, -- ** Merging events merge, mergeWith ) where import Control.Applicative import Data.Semigroup import Data.These (These(..)) import qualified Reactive.Banana.Prim.High.Combinators as Prim import Reactive.Banana.Types {----------------------------------------------------------------------------- Introduction ------------------------------------------------------------------------------} {-$synopsis The main types and combinators of Functional Reactive Programming (FRP). At its core, FRP is about two data types 'Event' and 'Behavior' and the various ways to combine them. There is also a third type 'Moment', which is necessary for the higher-order combinators. -} -- Event -- Behavior {----------------------------------------------------------------------------- Interpetation ------------------------------------------------------------------------------} -- | Interpret an event processing function. -- Useful for testing. -- -- Note: You can safely assume that this function is pure, -- even though the type seems to suggest otherwise. -- I'm really sorry about the extra 'IO', but it can't be helped. -- See source code for the sordid details. interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs -- FIXME: I would love to remove the 'IO' from the type signature, -- but unfortunately, it is possible that the argument to interpret -- returns an Event that was created in the context of an existing network, e.g. -- -- > eBad <- fromAddHandler ... -- > ... -- > let ys = interpret (\_ -> return eBad ) xs -- -- Doing this is a big no-no and will break a lot of things, -- but if we remove the 'IO' here, then we will also break referential -- transparency, and I think that takes it too far. {----------------------------------------------------------------------------- Core combinators ------------------------------------------------------------------------------} -- | Event that never occurs. -- Semantically, -- -- > never = [] never :: Event a never = E Prim.never -- | Merge two event streams of the same type. -- The function argument specifies how event values are to be combined -- in case of a simultaneous occurrence. The semantics are -- -- > unionWith f ((timex,x):xs) ((timey,y):ys) -- > | timex < timey = (timex,x) : unionWith f xs ((timey,y):ys) -- > | timex > timey = (timey,y) : unionWith f ((timex,x):xs) ys -- > | timex == timey = (timex,f x y) : unionWith f xs ys unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a unionWith f = mergeWith id id f -- | Merge two event streams of any type. merge :: Event a -> Event b -> Event (These a b) merge = mergeWith This That These -- | Merge two event streams of any type. -- -- This function generalizes 'unionWith'. mergeWith :: (a -> c) -- ^ The function called when only the first event emits a value. -> (b -> c) -- ^ The function called when only the second event emits a value. -> (a -> b -> c) -- ^ The function called when both events emit values simultaneously. -> Event a -> Event b -> Event c mergeWith f g h e1 e2 = E $ Prim.mergeWith f g h (unE e1) (unE e2) -- | Allow all event occurrences that are 'Just' values, discard the rest. -- Variant of 'filterE'. filterJust :: Event (Maybe a) -> Event a filterJust = E . Prim.filterJust . unE -- | Allow all events that fulfill the predicate, discard the rest. -- Semantically, -- -- > filterE p es = [(time,a) | (time,a) <- es, p a] filterE :: (a -> Bool) -> Event a -> Event a filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing) -- | Apply a time-varying function to a stream of events. -- Semantically, -- -- > apply bf ex = [(time, bf time x) | (time, x) <- ex] -- -- This function is generally used in its infix variant '<@>'. apply :: Behavior (a -> b) -> Event a -> Event b apply bf ex = E $ Prim.applyE (unB bf) (unE ex) -- | Construct a time-varying function from an initial value and -- a stream of new values. The result will be a step function. -- Semantically, -- -- > stepper x0 ex = \time1 -> \time2 -> -- > last (x0 : [x | (timex,x) <- ex, time1 <= timex, timex < time2]) -- -- Here is an illustration of the result Behavior at a particular time: -- -- <> -- -- Note: The smaller-than-sign in the comparison @timex < time2@ means -- that at time @time2 == timex@, the value of the Behavior will -- still be the previous value. -- In the illustration, this is indicated by the dots at the end -- of each step. -- This allows for recursive definitions. -- See the discussion below for more on recursion. stepper :: MonadMoment m => a -> Event a -> m (Behavior a) stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE -- | The 'accumE' function accumulates a stream of event values, -- similar to a /strict/ left scan, 'scanl''. -- It starts with an initial value and emits a new value -- whenever an event occurrence happens. -- The new value is calculated by applying the function in the event -- to the old value. -- -- Example: -- -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] -- > = trimE [(time1,"xy"),(time2,"xyz")] -- > where -- > trimE e start = [(time,x) | (time,x) <- e, start <= time] accumE :: MonadMoment m => a -> Event (a -> a) -> m (Event a) accumE acc = liftMoment . M . fmap E . Prim.accumE acc . unE {-$recursion /Recursion/ is a very important technique in FRP that is not apparent from the type signatures. Here is a prototypical example. It shows how the 'accumE' can be expressed in terms of the 'stepper' and 'apply' functions by using recursion: > accumE a e1 = mdo > let e2 = (\a f -> f a) <$> b <@> e1 > b <- stepper a e2 > return e2 (The @mdo@ notation refers to /value recursion/ in a monad. The 'MonadFix' instance for the 'Moment' class enables this kind of recursive code.) (Strictly speaking, this also means that 'accumE' is not a primitive, because it can be expressed in terms of other combinators.) This general pattern appears very often in practice: A Behavior (here @b@) controls what value is put into an Event (here @e2@), but at the same time, the Event contributes to changes in this Behavior. Modeling this situation requires recursion. For another example, consider a vending machine that sells banana juice. The amount that the customer still has to pay for a juice is modeled by a Behavior @bAmount@. Whenever the customer inserts a coin into the machine, an Event @eCoin@ occurs, and the amount will be reduced. Whenver the amount goes below zero, an Event @eSold@ will occur, indicating the release of a bottle of fresh banana juice, and the amount to be paid will be reset to the original price. The model requires recursion, and can be expressed in code as follows: > mdo > let price = 50 :: Int > bAmount <- accumB price $ unions > [ subtract 10 <$ eCoin > , const price <$ eSold ] > let eSold = whenE ((<= 0) <$> bAmount) eCoin On one hand, the Behavior @bAmount@ controls whether the Event @eSold@ occcurs at all; the bottle of banana juice is unavailable to penniless customers. But at the same time, the Event @eSold@ will cause a reset of the Behavior @bAmount@, so both depend on each other. Recursive code like this examples works thanks to the semantics of 'stepper'. In general, /mutual recursion/ between several 'Event's and 'Behavior's is always well-defined, as long as an Event depends on itself only /via/ a Behavior, and vice versa. -} -- | Obtain the value of the 'Behavior' at a given moment in time. -- Semantically, it corresponds to -- -- > valueB b = \time -> b time -- -- Note: The value is immediately available for pattern matching. -- Unfortunately, this means that @valueB@ is unsuitable for use -- with value recursion in the 'Moment' monad. -- If you need recursion, please use 'valueBLater' instead. valueB :: MonadMoment m => Behavior a -> m a valueB = liftMoment . M . Prim.valueB . unB -- | Obtain the value of the 'Behavior' at a given moment in time. -- Semantically, it corresponds to -- -- > valueBLater b = \time -> b time -- -- Note: To allow for more recursion, the value is returned /lazily/ -- and not available for pattern matching immediately. -- It can be used safely with most combinators like 'stepper'. -- If that doesn't work for you, please use 'valueB' instead. valueBLater :: MonadMoment m => Behavior a -> m a valueBLater = liftMoment . M . Prim.initialBLater . unB -- | Observe a value at those moments in time where -- event occurrences happen. Semantically, -- -- > observeE e = [(time, m time) | (time, m) <- e] observeE :: Event (Moment a) -> Event a observeE = E . Prim.observeE . Prim.mapE unM . unE -- | Dynamically switch between 'Event'. -- Semantically, -- -- > switchE e0 ee0 time0 = -- > concat [ trim t1 t2 e | (t1,t2,e) <- intervals ee ] -- > where -- > laterThan e time0 = [(timex,x) | (timex,x) <- e, time0 < timex ] -- > ee = [(time0, e0)] ++ (ee0 `laterThan` time0) -- > intervals ee = [(time1, time2, e) | ((time1,e),(time2,_)) <- zip ee (tail ee)] -- > trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2] switchE :: MonadMoment m => Event a -> Event (Event a) -> m (Event a) switchE e ee = liftMoment (M (fmap E (Prim.switchE (unE e) (Prim.mapE unE (unE ee))))) -- | Dynamically switch between 'Behavior'. -- Semantically, -- -- > switchB b0 eb = \time0 -> \time1 -> -- > last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1 switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a) switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE unB . unE {----------------------------------------------------------------------------- Derived Combinators ------------------------------------------------------------------------------} infixl 4 <@>, <@, @> -- | Infix synonym for the 'apply' combinator. Similar to '<*>'. -- -- > infixl 4 <@> (<@>) :: Behavior (a -> b) -> Event a -> Event b (<@>) = apply -- | Tag all event occurrences with a time-varying value. Similar to '<*'. -- -- > infixl 4 <@ (<@) :: Behavior b -> Event a -> Event b f <@ g = (const <$> f) <@> g -- | Tag all event occurences with a time-varying value. Similar to '*>'. -- -- This is the flipped version of '<@', but can be useful when combined with -- @ApplicativeDo@ to sample from multiple 'Behavior's: -- -- @ -- reactimate $ onEvent @> do -- x <- behavior1 -- y <- behavior2 -- return (print (x + y)) -- @ (@>) :: Event a -> Behavior b -> Event b g @> f = (const <$> f) <@> g -- | Allow all events that fulfill the time-varying predicate, discard the rest. -- Generalization of 'filterE'. filterApply :: Behavior (a -> Bool) -> Event a -> Event a filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp) -- | Allow events only when the behavior is 'True'. -- Variant of 'filterApply'. whenE :: Behavior Bool -> Event a -> Event a whenE bf = filterApply (const <$> bf) -- | Split event occurrences according to a tag. -- The 'Left' values go into the left component while the 'Right' values -- go into the right component of the result. split :: Event (Either a b) -> (Event a, Event b) split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) where fromLeft :: Either a b -> Maybe a fromLeft (Left a) = Just a fromLeft (Right _) = Nothing fromRight :: Either a b -> Maybe b fromRight (Left _) = Nothing fromRight (Right b) = Just b -- | Keep only the next occurence of an event. -- -- @once@ also aids the garbage collector by indicating that the result event can be discarded after its only occurrence. -- -- > once e = \time0 -> take 1 [(t, a) | (t, a) <- e, time0 <= t] once :: MonadMoment m => Event a -> m (Event a) once e = mdo e1 <- switchE e (never <$ e1) return e1 -- $Accumulation. -- Note: All accumulation functions are strict in the accumulated value! -- -- Note: The order of arguments is @acc -> (x,acc)@ -- which is also the convention used by 'unfoldr' and 'State'. -- | Merge event streams whose values are functions. -- In case of simultaneous occurrences, the functions at the beginning -- of the list are applied /after/ the functions at the end. -- -- > unions [] = never -- > unions xs = foldr1 (unionWith (.)) xs -- -- Very useful in conjunction with accumulation functions like 'accumB' -- and 'accumE'. unions :: [Event (a -> a)] -> Event (a -> a) unions [] = never unions xs = foldr1 (unionWith (.)) xs -- | The 'accumB' function accumulates event occurrences into a 'Behavior'. -- -- The value is accumulated using 'accumE' and converted -- into a time-varying value using 'stepper'. -- -- Example: -- -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] -- > = stepper "x" [(time1,"xy"),(time2,"xyz")] -- -- Note: As with 'stepper', the value of the behavior changes \"slightly after\" -- the events occur. This allows for recursive definitions. accumB :: MonadMoment m => a -> Event (a -> a) -> m (Behavior a) accumB acc e = stepper acc =<< accumE acc e -- | Efficient combination of 'accumE' and 'accumB'. mapAccum :: MonadMoment m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc) mapAccum acc ef = do e <- accumE (undefined,acc) (lift <$> ef) b <- stepper acc (snd <$> e) return (fst <$> e, b) where lift f (_,acc) = acc `seq` f acc reactive-banana-1.3.2.0/src/Reactive/Banana/Frameworks.hs0000644000000000000000000003522107346545000021254 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-} module Reactive.Banana.Frameworks ( -- * Synopsis -- | Connect to the outside world by building 'EventNetwork's -- and running them. -- * Simple use interpretAsHandler, -- * Overview -- $build -- * Building event networks with input/output -- ** Core functions compile, MomentIO, module Control.Event.Handler, fromAddHandler, fromChanges, fromPoll, reactimate, Future, reactimate', changes, -- $changes imposeChanges, execute, liftIOLater, -- $liftIO module Control.Monad.IO.Class, -- ** Utility functions -- | This section collects a few convience functions -- built from the core functions. interpretFrameworks, newEvent, mapEventIO, newBehavior, -- * Running event networks EventNetwork, actuate, pause, getSize, ) where import Control.Event.Handler import Control.Monad import Control.Monad.IO.Class import Data.IORef import Reactive.Banana.Combinators import qualified Reactive.Banana.Prim.High.Combinators as Prim import Reactive.Banana.Types {----------------------------------------------------------------------------- Documentation ------------------------------------------------------------------------------} {-$build After having read all about 'Event's and 'Behavior's, you want to hook them up to an existing event-based framework, like @wxHaskell@ or @Gtk2Hs@. How do you do that? The module presented here allows you to * obtain /input/ events from external sources and to * perform /output/ in reaction to events. In contrast, the functions from "Reactive.Banana.Combinators" allow you to express the output events in terms of the input events. This expression is called an /event graph/. An /event network/ is an event graph together with inputs and outputs. To build an event network, describe the inputs, outputs and event graph in the 'MomentIO' monad and use the 'compile' function to obtain an event network from that. To /activate/ an event network, use the 'actuate' function. The network will register its input event handlers and start producing output. A typical setup looks like this: > main = do > -- initialize your GUI framework > window <- newWindow > ... > > -- describe the event network > let networkDescription :: MomentIO () > networkDescription = do > -- input: obtain Event from functions that register event handlers > emouse <- fromAddHandler $ registerMouseEvent window > ekeyboard <- fromAddHandler $ registerKeyEvent window > -- input: obtain Behavior from changes > btext <- fromChanges "" $ registerTextChange editBox > -- input: obtain Behavior from mutable data by polling > bdie <- fromPoll $ randomRIO (1,6) > > -- express event graph > behavior1 <- accumB ... > let > ... > event15 = union event13 event14 > > -- output: animate some event occurrences > reactimate $ fmap print event15 > reactimate $ fmap drawCircle eventCircle > > -- compile network description into a network > network <- compile networkDescription > -- register handlers and start producing outputs > actuate network In short, * Use 'fromAddHandler' to obtain /input/ events. The library uses this to register event handlers with your event-based framework. * Use 'reactimate' to animate /output/ events. * Use 'compile' to put everything together in an 'EventNetwork's and use 'actuate' to start handling events. -} {----------------------------------------------------------------------------- Combinators ------------------------------------------------------------------------------} {- | Output. Execute the 'IO' action whenever the event occurs. Note: If two events occur very close to each other, there is no guarantee that the @reactimate@s for one event will have finished before the ones for the next event start executing. This does /not/ affect the values of events and behaviors, it only means that the @reactimate@ for different events may interleave. Fortunately, this is a very rare occurrence, and only happens if * you call an event handler from inside 'reactimate', * or you use concurrency. In these cases, the @reactimate@s follow the control flow of your event-based framework. Note: An event network essentially behaves like a single, huge callback function. The 'IO' action are not run in a separate thread. The callback function will throw an exception if one of your 'IO' actions does so as well. Your event-based framework will have to handle this situation. -} reactimate :: Event (IO ()) -> MomentIO () reactimate = MIO . Prim.addReactimate . Prim.mapE return . unE -- | Output. -- Execute the 'IO' action whenever the event occurs. -- -- This version of 'reactimate' can deal with values obtained -- from the 'changes' function. reactimate' :: Event (Future (IO ())) -> MomentIO () reactimate' = MIO . Prim.addReactimate . Prim.mapE unF . unE -- | Input, -- obtain an 'Event' from an 'AddHandler'. -- -- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called. fromAddHandler ::AddHandler a -> MomentIO (Event a) fromAddHandler = MIO . fmap E . Prim.fromAddHandler -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time. -- -- The resulting 'Behavior' will be updated on whenever the event -- network processes an input event. -- -- This function is occasionally useful, but -- the recommended way to obtain 'Behaviors' is by using 'fromChanges'. -- -- Ideally, the argument IO action just polls a mutable variable, -- it should not perform expensive computations. -- Neither should its side effects affect the event network significantly. fromPoll :: IO a -> MomentIO (Behavior a) fromPoll = MIO . fmap B . Prim.fromPoll -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes. -- -- This is essentially just an application of the 'stepper' combinator. fromChanges :: a -> AddHandler a -> MomentIO (Behavior a) fromChanges initial changes = do e <- fromAddHandler changes stepper initial e -- | Output, -- return an 'Event' that is adapted to the changes of a 'Behavior'. -- -- Remember that semantically, a 'Behavior' is a function @Behavior a = Time -> a@. -- This means that a Behavior does not have a notion of \"changes\" associated with it. -- For instance, the following Behaviors are equal: -- -- > stepper 0 [] -- > = stepper 0 [(time1, 0), (time2, 0)] -- > = stepper 0 $ zip [time1,time2..] (repeat 0) -- -- In principle, to perform IO actions with the value of a Behavior, -- one has to sample it using an 'Event' and the 'apply' function. -- -- However, in practice, Behaviors are usually step functions. -- For reasons of efficiency, the library provides a way -- to obtain an Event that /mostly/ coincides with the steps of a Behavior, -- so that sampling is only done at a few select points in time. -- The idea is that -- -- > changes =<< stepper x e = return e -- -- Please use 'changes' only in a ways that do /not/ distinguish -- between the different expressions for the same Behavior above. -- -- Note that the value of the event is actually the /new/ value, -- i.e. that value slightly after this point in time. (See the documentation of 'stepper'). -- This is more convenient. -- However, the value will not become available until after event processing is complete; -- this is indicated by the type 'Future'. -- It can be used only in the context of 'reactimate''. changes :: Behavior a -> MomentIO (Event (Future a)) changes = return . E . Prim.mapE F . Prim.changesB . unB {- $changes Note: If you need a variant of the 'changes' function that does /not/ have the additional 'Future' type, then the following code snippet may be useful: > plainChanges :: Behavior a -> MomentIO (Event a) > plainChanges b = do > (e, handle) <- newEvent > eb <- changes b > reactimate' $ (fmap handle) <$> eb > return e However, this approach is not recommended, because the result 'Event' will occur /slightly/ later than the event returned by 'changes'. In fact, there is no guarantee whatsoever about what /slightly/ means in this context. Still, it is useful in some cases. -} -- | Impose a different sampling event on a 'Behavior'. -- -- The 'Behavior' will have the same values as before, but the event returned -- by the 'changes' function will now happen simultaneously with the -- imposed event. -- -- Note: This function is useful only in very specific circumstances. imposeChanges :: Behavior a -> Event () -> Behavior a imposeChanges b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e)) {- | Dynamically add input and output to an existing event network. Note: You can perform 'IO' actions here, which is useful if you want to register additional event handlers dynamically. However, if two arguments to 'execute' occur simultaneously, then the order in which the 'IO' therein are executed is unspecified. For instance, in the following code > example e = do > e1 <- execute (liftIO (putStrLn "A") <$ e) > e2 <- execute (liftIO (putStrLn "B") <$ e) > return (e1,e2) it is unspecified whether @A@ or @B@ are printed first. Moreover, if the result 'Event' of this function has been garbage collected, it may also happen that the actions are not executed at all. In the example above, if the events `e1` and `e2` are not used any further, then it can be that neither @A@ nor @B@ will be printed. If your main goal is to reliably turn events into 'IO' actions, use the 'reactimate' and 'reactimate'' functions instead. -} execute :: Event (MomentIO a) -> MomentIO (Event a) execute = MIO . fmap E . Prim.executeE . Prim.mapE unMIO . unE -- $liftIO -- -- > liftIO :: Frameworks t => IO a -> Moment t a -- -- Lift an 'IO' action into the 'Moment' monad. -- | Lift an 'IO' action into the 'Moment' monad, -- but defer its execution until compilation time. -- This can be useful for recursive definitions using 'MonadFix'. liftIOLater :: IO () -> MomentIO () liftIOLater = MIO . Prim.liftIOLater -- | Compile the description of an event network -- into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on. compile :: MomentIO () -> IO EventNetwork compile = fmap EN . Prim.compile . unMIO {----------------------------------------------------------------------------- Running event networks ------------------------------------------------------------------------------} -- | Data type that represents a compiled event network. -- It may be paused or already running. newtype EventNetwork = EN { unEN :: Prim.EventNetwork } -- | Actuate an event network. -- The inputs will register their event handlers, so that -- the networks starts to produce outputs in response to input events. actuate :: EventNetwork -> IO () actuate = Prim.actuate . unEN -- | Pause an event network. -- Immediately stop producing output. -- (In a future version, it will also unregister all event handlers for inputs.) -- Hence, the network stops responding to input events, -- but it's state will be preserved. -- -- You can resume the network with 'actuate'. -- -- Note: You can stop a network even while it is processing events, -- i.e. you can use 'pause' as an argument to 'reactimate'. -- The network will /not/ stop immediately though, only after -- the current event has been processed completely. pause :: EventNetwork -> IO () pause = Prim.pause . unEN -- | PROVISIONAL. -- Measure of the number of events in the event network. -- Useful for understanding space usage. getSize :: EventNetwork -> IO Int getSize = Prim.getSize . unEN {----------------------------------------------------------------------------- Utilities ------------------------------------------------------------------------------} -- | Build an 'Event' together with an 'IO' action that can -- fire occurrences of this event. Variant of 'newAddHandler'. -- -- This function is mainly useful for passing callback functions -- inside a 'reactimate'. newEvent :: MomentIO (Event a, Handler a) newEvent = do (addHandler, fire) <- liftIO newAddHandler e <- fromAddHandler addHandler return (e,fire) -- | Build a 'Behavior' together with an 'IO' action that can -- update this behavior with new values. -- -- Implementation: -- -- > newBehavior a = do -- > (e, fire) <- newEvent -- > b <- stepper a e -- > return (b, fire) newBehavior :: a -> MomentIO (Behavior a, Handler a) newBehavior a = do (e, fire) <- newEvent b <- stepper a e return (b, fire) -- | Build a new 'Event' that contains the result -- of an IO computation. -- The input and result events will /not/ be simultaneous anymore, -- the latter will occur /later/ than the former. -- -- Please use the 'fmap' for 'Event' if your computation is pure. -- -- Implementation: -- -- > mapEventIO f e1 = do -- > (e2, handler) <- newEvent -- > reactimate $ (\a -> f a >>= handler) <$> e1 -- > return e2 mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b) mapEventIO f e1 = do (e2, handler) <- newEvent reactimate $ (f >=> handler) <$> e1 return e2 {----------------------------------------------------------------------------- Simple use ------------------------------------------------------------------------------} -- | Interpret an event processing function by building an 'EventNetwork' -- and running it. Useful for testing, but uses 'MomentIO'. -- See 'interpret' for a plain variant. interpretFrameworks :: (Event a -> MomentIO (Event b)) -> [Maybe a] -> IO [Maybe b] interpretFrameworks f xs = do output <- newIORef Nothing (addHandler, runHandlers) <- newAddHandler network <- compile $ do e1 <- fromAddHandler addHandler e2 <- f e1 reactimate $ writeIORef output . Just <$> e2 actuate network forM xs $ \x -> do case x of Nothing -> return Nothing Just x -> do runHandlers x b <- readIORef output writeIORef output Nothing return b -- | Simple way to write a single event handler with -- functional reactive programming. interpretAsHandler :: (Event a -> Moment (Event b)) -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do network <- compile $ do e1 <- fromAddHandler addHandlerA e2 <- liftMoment (f e1) reactimate $ handlerB <$> e2 actuate network return (pause network) reactive-banana-1.3.2.0/src/Reactive/Banana/Model.hs0000644000000000000000000001431707346545000020177 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Reactive.Banana.Model ( -- * Synopsis -- | Model implementation for learning and testing. -- * Overview -- $overview -- * Core Combinators -- ** Event and Behavior Nat, Time, Event(..), Behavior(..), interpret, -- ** First-order module Control.Applicative, never, unionWith, mergeWith, filterJust, apply, -- ** Moment and accumulation Moment(..), accumE, stepper, -- ** Higher-order valueB, observeE, switchE, switchB, ) where import Control.Applicative import Control.Monad import Control.Monad.Fix import Data.These (These(..), these) import Data.Maybe (fromMaybe) {-$overview This module reimplements the key FRP types and functions from the module "Reactive.Banana.Combinators" in a way that is hopefully easier to understand. Thereby, this model also specifies the semantics of the library. Of course, the real implementation is much more efficient than this model here. To understand the model in detail, look at the source code! (If there is no link to the source code at every type signature, then you have to run cabal with --hyperlink-source flag.) This model is /authoritative/: Event functions that have been constructed using the same combinators /must/ give the same results when run with the @interpret@ function from either the module "Reactive.Banana.Combinators" or the module "Reactive.Banana.Model". This must also hold for recursive and partial definitions (at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). -} {----------------------------------------------------------------------------- Event and Behavior ------------------------------------------------------------------------------} -- | Natural numbers (poorly represented). type Nat = Int -- | The FRP model used in this library is actually a model with continuous time. -- -- However, it can be shown that this model is observationally -- equivalent to a particular model with (seemingly) discrete time steps, -- which is implemented here. -- The main reason for doing this is to be able to handle recursion correctly. -- Details will be explained elsewhere. type Time = Nat -- begins at t = 0 -- | Event is modeled by an /infinite/ list of 'Maybe' values. -- It is isomorphic to @Time -> Maybe a@. -- -- 'Nothing' indicates that no occurrence happens, -- while 'Just' indicates that an occurrence happens. newtype Event a = E { unE :: [Maybe a] } deriving (Show) -- | Behavior is modeled by an /infinite/ list of values. -- It is isomorphic to @Time -> a@. newtype Behavior a = B { unB :: [a] } deriving (Show) interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] interpret f as = take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing) {----------------------------------------------------------------------------- First-order ------------------------------------------------------------------------------} instance Functor Event where fmap f (E xs) = E (fmap (fmap f) xs) instance Functor Behavior where fmap f (B xs) = B (fmap f xs) instance Applicative Behavior where pure x = B $ repeat x (B f) <*> (B x) = B $ zipWith ($) f x never :: Event a never = E $ repeat Nothing unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a unionWith = mergeWith id id mergeWith :: (a -> c) -> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c mergeWith f g h xs ys = these f g h <$> merge xs ys merge :: Event a -> Event b -> Event (These a b) merge (E xs) (E ys) = E $ zipWith combine xs ys where combine Nothing Nothing = Nothing combine (Just x) Nothing = Just (This x) combine Nothing (Just y) = Just (That y) combine (Just x) (Just y) = Just (These x y) filterJust :: Event (Maybe a) -> Event a filterJust = E . fmap join . unE apply :: Behavior (a -> b) -> Event a -> Event b apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE {----------------------------------------------------------------------------- Moment and accumulation ------------------------------------------------------------------------------} newtype Moment a = M { unM :: Time -> a } instance Functor Moment where fmap f = M . fmap f . unM instance Applicative Moment where pure = M . const (<*>) = ap instance Monad Moment where return = pure (M m) >>= k = M $ \time -> unM (k $ m time) time instance MonadFix Moment where mfix f = M $ mfix (unM . f) -- Forget all event occurences before a particular time forgetE :: Time -> Event a -> [Maybe a] forgetE time (E xs) = drop time xs stepper :: a -> Event a -> Moment (Behavior a) stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e) where step i ~(x:xs) = i : step next xs where next = fromMaybe i x -- Expressed using recursion and the other primitives -- FIXME: Strictness! accumE :: a -> Event (a -> a) -> Moment (Event a) accumE a e1 = mdo let e2 = ((\a f -> f a) <$> b) `apply` e1 b <- stepper a e2 return e2 {----------------------------------------------------------------------------- Higher-order ------------------------------------------------------------------------------} valueB :: Behavior a -> Moment a valueB (B b) = M $ \time -> b !! time observeE :: Event (Moment a) -> Event a observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE switchE :: Event a -> Event (Event a) -> Moment (Event a) switchE e es = M $ \t -> E $ replicate t Nothing ++ switch (unE e) (forgetE t (forgetDiagonalE es)) where switch (x:xs) (Nothing : ys) = x : switch xs ys switch (x: _) (Just xs : ys) = x : switch (tail xs) ys forgetDiagonalE :: Event (Event a) -> Event [Maybe a] forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a) switchB b e = diagonalB <$> stepper b e diagonalB :: Behavior (Behavior a) -> Behavior a diagonalB = B . zipWith (\time xs -> xs !! time) [0..] . map unB . unB reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/High/0000755000000000000000000000000007346545000020363 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/High/Cached.hs0000644000000000000000000000425107346545000022070 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.High.Cached ( -- | Utility for executing monadic actions once -- and then retrieving values from a cache. -- -- Very useful for observable sharing. Cached, runCached, cache, fromPure, don'tCache, liftCached1, liftCached2, ) where import Control.Monad.Fix import Control.Monad.IO.Class import Data.IORef import System.IO.Unsafe (unsafePerformIO) {----------------------------------------------------------------------------- Cache type ------------------------------------------------------------------------------} data Cached m a = Cached (m a) runCached :: Cached m a -> m a runCached (Cached x) = x -- | An action whose result will be cached. -- Executing the action the first time in the monad will -- execute the side effects. From then on, -- only the generated value will be returned. {-# NOINLINE cache #-} cache :: (MonadFix m, MonadIO m) => m a -> Cached m a cache m = unsafePerformIO $ do key <- liftIO $ newIORef Nothing return $ Cached $ do ma <- liftIO $ readIORef key -- read the cached result case ma of Just a -> return a -- return the cached result. Nothing -> mdo liftIO $ -- write the result already writeIORef key (Just a) a <- m -- evaluate return a -- | Return a pure value. Doesn't make use of the cache. fromPure :: Monad m => a -> Cached m a fromPure = Cached . return -- | Lift an action that is /not/ cached, for instance because it is idempotent. don'tCache :: Monad m => m a -> Cached m a don'tCache = Cached liftCached1 :: (MonadFix m, MonadIO m) => (a -> m b) -> Cached m a -> Cached m b liftCached1 f ca = cache $ do a <- runCached ca f a liftCached2 :: (MonadFix m, MonadIO m) => (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c liftCached2 f ca cb = cache $ do a <- runCached ca b <- runCached cb f a b reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/High/Combinators.hs0000644000000000000000000002175207346545000023206 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE FlexibleInstances, NamedFieldPuns, NoMonomorphismRestriction #-} module Reactive.Banana.Prim.High.Combinators where import Control.Exception import Control.Concurrent.MVar import Control.Event.Handler import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader import Data.IORef import qualified Reactive.Banana.Prim.Mid as Prim import Reactive.Banana.Prim.High.Cached type Build = Prim.Build type Latch a = Prim.Latch a type Pulse a = Prim.Pulse a type Future = Prim.Future {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} type Behavior a = Cached Moment (Latch a, Pulse ()) type Event a = Cached Moment (Pulse a) type Moment = ReaderT EventNetwork Prim.Build liftBuild :: Build a -> Moment a liftBuild = lift {----------------------------------------------------------------------------- Interpretation ------------------------------------------------------------------------------} interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined where g pulse = runCached =<< f (Prim.fromPure pulse) -- Ignore any addHandler inside the Moment {----------------------------------------------------------------------------- IO ------------------------------------------------------------------------------} -- | Data type representing an event network. data EventNetwork = EventNetwork { actuated :: IORef Bool , size :: IORef Int , s :: MVar Prim.Network } runStep :: EventNetwork -> Prim.Step -> IO () runStep EventNetwork{ actuated, s, size } f = whenFlag actuated $ do output <- mask $ \restore -> do s1 <- takeMVar s -- read and take lock -- pollValues <- sequence polls -- poll mutable data (output, s2) <- restore (f s1) -- calculate new state `onException` putMVar s s1 -- on error, restore the original state putMVar s s2 -- write state writeIORef size =<< Prim.getSize s2 return output output -- run IO actions afterwards where whenFlag flag action = readIORef flag >>= \b -> when b action getSize :: EventNetwork -> IO Int getSize EventNetwork{size} = readIORef size actuate :: EventNetwork -> IO () actuate EventNetwork{ actuated } = writeIORef actuated True pause :: EventNetwork -> IO () pause EventNetwork{ actuated } = writeIORef actuated False -- | Compile to an event network. compile :: Moment () -> IO EventNetwork compile setup = do actuated <- newIORef False -- flag to set running status s <- newEmptyMVar -- setup callback machinery size <- newIORef 0 let eventNetwork = EventNetwork{ actuated, s, size } (_output, s0) <- -- compile initial graph Prim.compile (runReaderT setup eventNetwork) =<< Prim.emptyNetwork putMVar s s0 -- set initial state writeIORef size =<< Prim.getSize s0 return eventNetwork fromAddHandler :: AddHandler a -> Moment (Event a) fromAddHandler addHandler = do (p, fire) <- liftBuild Prim.newInput network <- ask _unregister <- liftIO $ register addHandler $ runStep network . fire return $ Prim.fromPure p addReactimate :: Event (Future (IO ())) -> Moment () addReactimate e = do network <- ask liftBuild $ Prim.buildLater $ do -- Run cached computation later to allow more recursion with `Moment` p <- runReaderT (runCached e) network Prim.addHandler p id fromPoll :: IO a -> Moment (Behavior a) fromPoll poll = do a <- liftIO poll e <- liftBuild $ do p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP return $ Prim.fromPure p stepperB a e liftIONow :: IO a -> Moment a liftIONow = liftIO liftIOLater :: IO () -> Moment () liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater imposeChanges :: Behavior a -> Event () -> Behavior a imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2) {----------------------------------------------------------------------------- Combinators - basic ------------------------------------------------------------------------------} never :: Event a never = don'tCache $ liftBuild Prim.neverP mergeWith :: (a -> c) -> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y)) filterJust :: Event (Maybe a) -> Event a filterJust = liftCached1 $ liftBuild . Prim.filterJustP mapE :: (a -> b) -> Event a -> Event b mapE f = liftCached1 $ liftBuild . Prim.mapP f applyE :: Behavior (a -> b) -> Event a -> Event b applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px changesB :: Behavior a -> Event (Future a) changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px pureB :: a -> Behavior a pureB a = cache $ do p <- runCached never return (Prim.pureL a, p) applyB :: Behavior (a -> b) -> Behavior a -> Behavior b applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2 let l3 = Prim.applyL l1 l2 return (l3,p3) mapB :: (a -> b) -> Behavior a -> Behavior b mapB f = applyB (pureB f) {----------------------------------------------------------------------------- Combinators - accumulation ------------------------------------------------------------------------------} -- Make sure that the cached computation (Event or Behavior) -- is executed eventually during this moment. trim :: Cached Moment a -> Moment (Cached Moment a) trim b = do liftBuildFun Prim.buildLater $ void $ runCached b return b -- Cache a computation at this moment in time -- and make sure that it is performed in the Build monad eventually cacheAndSchedule :: Moment a -> Moment (Cached Moment a) cacheAndSchedule m = ask >>= \r -> liftBuild $ do let c = cache (const m r) -- prevent let-floating! Prim.buildLater $ void $ runReaderT (runCached c) r return c stepperB :: a -> Event a -> Moment (Behavior a) stepperB a e = cacheAndSchedule $ do p0 <- runCached e liftBuild $ do p1 <- Prim.mapP const p0 p2 <- Prim.mapP (const ()) p1 (l,_) <- Prim.accumL a p1 return (l,p2) accumE :: a -> Event (a -> a) -> Moment (Event a) accumE a e1 = cacheAndSchedule $ do p0 <- runCached e1 liftBuild $ do (_,p1) <- Prim.accumL a p0 return p1 {----------------------------------------------------------------------------- Combinators - dynamic event switching ------------------------------------------------------------------------------} liftBuildFun :: (Build a -> Build b) -> Moment a -> Moment b liftBuildFun f m = do r <- ask liftBuild $ f $ runReaderT m r valueB :: Behavior a -> Moment a valueB b = do ~(l,_) <- runCached b liftBuild $ Prim.readLatch l initialBLater :: Behavior a -> Moment a initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB executeP :: Pulse (Moment a) -> Moment (Pulse a) executeP p1 = do r <- ask liftBuild $ do p2 <- Prim.mapP runReaderT p1 Prim.executeP p2 r observeE :: Event (Moment a) -> Event a observeE = liftCached1 executeP executeE :: Event (Moment a) -> Moment (Event a) executeE e = do -- Run cached computation later to allow more recursion with `Moment` p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e return $ fromPure p switchE :: Event a -> Event (Event a) -> Moment (Event a) switchE e0 e = ask >>= \r -> cacheAndSchedule $ do p0 <- runCached e0 p1 <- runCached e liftBuild $ do p2 <- Prim.mapP (runReaderT . runCached) p1 p3 <- Prim.executeP p2 r Prim.switchP p0 p3 switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a) switchB b e = ask >>= \r -> cacheAndSchedule $ do ~(l0,p0) <- runCached b p1 <- runCached e liftBuild $ do p2 <- Prim.mapP (runReaderT . runCached) p1 p3 <- Prim.executeP p2 r lr <- Prim.switchL l0 =<< Prim.mapP fst p3 -- TODO: switch away the initial behavior let c1 = p0 -- initial behavior changes c2 <- Prim.mapP (const ()) p3 -- or switch happens never <- Prim.neverP c3 <- Prim.switchP never =<< Prim.mapP snd p3 -- or current behavior changes pr <- merge c1 =<< merge c2 c3 return (lr, pr) merge :: Pulse () -> Pulse () -> Build (Pulse ()) merge = Prim.mergeWithP Just Just (\_ _ -> Just ()) reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/0000755000000000000000000000000007346545000020245 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Graph.hs0000644000000000000000000002451207346545000021646 0ustar0000000000000000{-# language BangPatterns #-} {-# language NamedFieldPuns #-} {-# language RecordWildCards #-} {-# language ScopedTypeVariables #-} {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Prim.Low.Graph ( Graph , empty , getOutgoing , getIncoming , size , edgeCount , listConnectedVertices , deleteVertex , insertEdge , deleteEdge , clearPredecessors , collectGarbage , topologicalSort , Step (..) , walkSuccessors , walkSuccessors_ -- * Internal , Level , getLevel -- * Debugging , showDot ) where import Data.Functor.Identity ( Identity (..) ) import Data.Hashable ( Hashable ) import Data.Maybe ( fromMaybe ) import Reactive.Banana.Prim.Low.GraphTraversal ( reversePostOrder ) import qualified Data.List as L import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import qualified Data.PQueue.Prio.Min as Q type Queue = Q.MinPQueue type Map = Map.HashMap type Set = Set.HashSet {----------------------------------------------------------------------------- Levels ------------------------------------------------------------------------------} -- | 'Level's are used to keep track of the order of vertices — -- Lower levels come first. type Level = Int ground :: Level ground = 0 {----------------------------------------------------------------------------- Graph ------------------------------------------------------------------------------} {- | A directed graph whose set of vertices is the set of all values of the type @v@ and whose edges are associated with data of type @e@. Note that a 'Graph' does not have a notion of vertex membership — by design, /all/ values of the type @v@ are vertices of the 'Graph'. The main purpose of 'Graph' is to keep track of directed edges between vertices; a vertex with at least one edge incident on it is called a /connected vertex/. For efficiency, only the connected vertices are stored. -} data Graph v e = Graph { -- | Mapping from each vertex to its direct successors -- (possibly empty). outgoing :: !(Map v (Map v e)) -- | Mapping from each vertex to its direct predecessors -- (possibly empty). , incoming :: !(Map v (Map v e)) -- | Mapping from each vertex to its 'Level'. -- Invariant: If x precedes y, then x has a lower level than y. , levels :: !(Map v Level) } deriving (Eq, Show) -- | The graph with no edges. empty :: Graph v e empty = Graph { outgoing = Map.empty , incoming = Map.empty , levels = Map.empty } -- | Get all direct successors of a vertex in a 'Graph'. getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)] getOutgoing Graph{outgoing} x = map shuffle $ Map.toList $ fromMaybe Map.empty $ Map.lookup x outgoing where shuffle (x,y) = (y,x) -- | Get all direct predecessors of a vertex in a 'Graph'. getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)] getIncoming Graph{incoming} x = Map.toList $ fromMaybe Map.empty $ Map.lookup x incoming -- | Get the 'Level' of a vertex in a 'Graph'. getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level getLevel Graph{levels} x = fromMaybe ground $ Map.lookup x levels -- | List all connected vertices, -- i.e. vertices on which at least one edge is incident. listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v] listConnectedVertices Graph{incoming,outgoing} = Map.keys $ (() <$ outgoing) `Map.union` (() <$ incoming) -- | Number of connected vertices, -- i.e. vertices on which at least one edge is incident. size :: (Eq v, Hashable v) => Graph v e -> Int size Graph{incoming,outgoing} = Map.size $ (() <$ outgoing) `Map.union` (() <$ incoming) -- | Number of edges. edgeCount :: (Eq v, Hashable v) => Graph v e -> Int edgeCount Graph{incoming,outgoing} = (count incoming + count outgoing) `div` 2 where count = Map.foldl' (\a v -> Map.size v + a) 0 {----------------------------------------------------------------------------- Insertion ------------------------------------------------------------------------------} -- | Insert an edge from the first to the second vertex into the 'Graph'. insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e insertEdge (x,y) exy g0@Graph{..} = Graph { outgoing = Map.insertWith (\new old -> new <> old) x (Map.singleton y exy) $ insertDefaultIfNotMember y Map.empty $ outgoing , incoming = Map.insertWith (\new old -> new <> old) y (Map.singleton x exy) . insertDefaultIfNotMember x Map.empty $ incoming , levels = adjustLevels $ levels0 } where getLevel z = fromMaybe ground . Map.lookup z levels0 = insertDefaultIfNotMember x (ground-1) . insertDefaultIfNotMember y ground $ levels levelDifference = getLevel y levels0 - 1 - getLevel x levels0 adjustLevel g x = Map.adjust (+ levelDifference) x g adjustLevels ls | levelDifference >= 0 = ls | otherwise = L.foldl' adjustLevel ls predecessors where Identity predecessors = reversePostOrder [x] (Identity . map fst . getIncoming g0) -- Helper function: Insert a default value if the key is not a member yet insertDefaultIfNotMember :: (Eq k, Hashable k) => k -> a -> Map k a -> Map k a insertDefaultIfNotMember x def = Map.insertWith (\_ old -> old) x def {----------------------------------------------------------------------------- Deletion ------------------------------------------------------------------------------} -- | TODO: Not implemented. deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e deleteEdge (x,y) g = Graph { outgoing = undefined x g , incoming = undefined y g , levels = undefined } -- | Remove all edges incident on this vertex from the 'Graph'. deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e deleteVertex x = clearLevels . clearPredecessors x . clearSuccessors x where clearLevels g@Graph{levels} = g{levels = Map.delete x levels} -- | Remove all the edges that connect the given vertex to its predecessors. clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e clearPredecessors x g@Graph{..} = g { outgoing = foldr ($) outgoing [ Map.adjust (Map.delete x) z | (z,_) <- getIncoming g x ] , incoming = Map.delete x incoming } -- | Remove all the edges that connect the given vertex to its successors. clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e clearSuccessors x g@Graph{..} = g { outgoing = Map.delete x outgoing , incoming = foldr ($) incoming [ Map.adjust (Map.delete x) z | (_,z) <- getOutgoing g x ] } -- | Apply `deleteVertex` to all vertices which are not predecessors -- of any of the vertices in the given list. collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e collectGarbage roots g@Graph{incoming,outgoing} = g { incoming = Map.filterWithKey (\v _ -> isReachable v) incoming -- incoming edges of reachable members are reachable by definition , outgoing = Map.map (Map.filterWithKey (\v _ -> isReachable v)) $ Map.filterWithKey (\v _ -> isReachable v) outgoing } where isReachable x = x `Set.member` reachables reachables = Set.fromList . runIdentity $ reversePostOrder roots $ Identity . map fst . getIncoming g {----------------------------------------------------------------------------- Topological sort ------------------------------------------------------------------------------} -- | If the 'Graph' is acyclic, return a topological sort, -- that is a linear ordering of its connected vertices such that -- each vertex occurs before its successors. -- -- (Vertices that are not connected are not listed in the topological sort.) -- -- https://en.wikipedia.org/wiki/Topological_sorting topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v] topologicalSort g@Graph{incoming} = runIdentity $ reversePostOrder roots (Identity . map snd . getOutgoing g) where -- all vertices that have no (direct) predecessors roots = [ x | (x,preds) <- Map.toList incoming, null preds ] data Step = Next | Stop -- | Starting from a list of vertices without predecessors, -- walk through all successors, but in such a way that every vertex -- is visited before its predecessors. -- For every vertex, if the function returns `Next`, then -- the successors are visited, otherwise the walk at the vertex -- stops prematurely. -- -- > topologicalSort g = -- > runIdentity $ walkSuccessors (roots g) (pure Next) g -- walkSuccessors :: forall v e m. (Monad m, Eq v, Hashable v) => [v] -> (v -> m Step) -> Graph v e -> m [v] walkSuccessors xs step g = go (Q.fromList $ zipLevels xs) Set.empty [] where zipLevels vs = [(getLevel g v, v) | v <- vs] go :: Queue Level v -> Set v -> [v] -> m [v] go q0 seen visits = case Q.minView q0 of Nothing -> pure $ reverse visits Just (v,q1) | v `Set.member` seen -> go q1 seen visits | otherwise -> do next <- step v let q2 = case next of Stop -> q1 Next -> let successors = zipLevels $ map snd $ getOutgoing g v in insertList q1 successors go q2 (Set.insert v seen) (v:visits) insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v insertList = L.foldl' (\q (k,v) -> Q.insert k v q) walkSuccessors_ :: (Monad m, Eq v, Hashable v) => [v] -> (v -> m Step) -> Graph v e -> m () walkSuccessors_ xs step g = walkSuccessors xs step g >> pure () {----------------------------------------------------------------------------- Debugging ------------------------------------------------------------------------------} -- | Map to a string in @graphviz@ dot file format. showDot :: (Eq v, Hashable v) => (v -> String) -> Graph v e -> String showDot fv g = unlines $ [ "digraph mygraph {" , " node [shape=box];" ] <> map showVertex (listConnectedVertices g) <> ["}"] where showVertex x = concat [ " " <> showEdge x y <> "; " | (_,y) <- getOutgoing g x ] showEdge x y = escape x <> " -> " <> escape y escape = show . fv reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphGC.hs0000644000000000000000000001747007346545000022065 0ustar0000000000000000{-# 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, ()) reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/GraphTraversal.hs0000644000000000000000000000320107346545000023522 0ustar0000000000000000{----------------------------------------------------------------------------- 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' reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/OrderedBag.hs0000644000000000000000000000325407346545000022603 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Implementation of a bag whose elements are ordered by arrival time. ------------------------------------------------------------------------------} {-# LANGUAGE TupleSections #-} module Reactive.Banana.Prim.Low.OrderedBag where import qualified Data.HashMap.Strict as Map import Data.Hashable import Data.List ( foldl', sortBy ) import Data.Maybe import Data.Ord {----------------------------------------------------------------------------- Ordered Bag ------------------------------------------------------------------------------} type Position = Integer data OrderedBag a = OB !(Map.HashMap a Position) !Position empty :: OrderedBag a empty = OB Map.empty 0 -- | Add an element to an ordered bag after all the others. -- Does nothing if the element is already in the bag. insert :: (Eq a, Hashable a) => OrderedBag a -> a -> OrderedBag a insert (OB xs n) x = OB (Map.insertWith (\_new old -> old) x n xs) (n+1) -- | Add a sequence of elements to an ordered bag. -- -- The ordering is left-to-right. For example, the head of the sequence -- comes after all elements in the bag, -- but before the other elements in the sequence. inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a inserts = foldl' insert -- | Reorder a list of elements to appear as they were inserted into the bag. -- Remove any elements from the list that do not appear in the bag. inOrder :: (Eq a, Hashable a) => [(a,b)] -> OrderedBag a -> [(a,b)] inOrder xs (OB bag _) = map snd $ sortBy (comparing fst) $ mapMaybe (\x -> (,x) <$> Map.lookup (fst x) bag) xs reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Low/Ref.hs0000644000000000000000000001050507346545000021316 0ustar0000000000000000{-# 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 #) reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/0000755000000000000000000000000007346545000017504 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid.hs0000644000000000000000000000723107346545000020554 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Prim.Mid ( -- * Synopsis -- | This is an internal module, useful if you want to -- implemented your own FRP library. -- If you just want to use FRP in your project, -- have a look at "Reactive.Banana" instead. -- * Evaluation Step, EvalNetwork, Network, emptyNetwork, getSize, -- * Build FRP networks Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile, module Control.Monad.IO.Class, -- * Caching module Reactive.Banana.Prim.High.Cached, -- * Testing interpret, mapAccumM, mapAccumM_, runSpaceProfile, -- * IO newInput, addHandler, readLatch, -- * Pulse Pulse, neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP, -- * Latch Latch, pureL, mapL, applyL, accumL, applyP, -- * Dynamic event switching switchL, executeP, switchP, -- * Notes -- $recursion -- * Debugging printDot ) where import Control.Monad.IO.Class import Reactive.Banana.Prim.Mid.Combinators import Reactive.Banana.Prim.Mid.Compile import Reactive.Banana.Prim.Mid.IO import Reactive.Banana.Prim.Mid.Plumbing ( neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater ) import Reactive.Banana.Prim.Mid.Types import Reactive.Banana.Prim.High.Cached {----------------------------------------------------------------------------- Notes ------------------------------------------------------------------------------} -- Note [Recursion] {- $recursion The 'Build' monad is an instance of 'MonadFix' and supports value recursion. However, it is built on top of the 'IO' monad, so the recursion is somewhat limited. The main rule for value recursion in the 'IO' monad is that the action to be performed must be known in advance. For instance, the following snippet will not work, because 'putStrLn' cannot complete its action without inspecting @x@, which is not defined until later. > mdo > putStrLn x > let x = "Hello recursion" On the other hand, whenever the sequence of 'IO' actions can be known before inspecting any later arguments, the recursion works. For instance the snippet > mdo > p1 <- mapP p2 > p2 <- neverP > return p1 works because 'mapP' does not inspect its argument. In other words, a call @p1 <- mapP undefined@ would perform the same sequence of 'IO' actions. (Internally, it essentially calls 'newIORef'.) With this issue in mind, almost all operations that build 'Latch' and 'Pulse' values have been carefully implemented to not inspect their arguments. In conjunction with the 'Cached' mechanism for observable sharing, this allows us to build combinators that can be used recursively. One notable exception is the 'readLatch' function, which must inspect its argument in order to be able to read its value. -} -- Note [LatchStrictness] {- Any value that is stored in the graph over a longer period of time must be stored in WHNF. This implies that the values in a latch must be forced to WHNF when storing them. That doesn't have to be immediately since we are tying a knot, but it definitely has to be done before evaluateGraph is done. It also implies that reading a value from a latch must be forced to WHNF before storing it again, so that we don't carry around the old collection of latch values. This is particularly relevant for `applyL`. Conversely, since latches are the only way to store values over time, this is enough to guarantee that there are no space leaks in this regard. -} reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/0000755000000000000000000000000007346545000020215 5ustar0000000000000000reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Combinators.hs0000644000000000000000000001155507346545000023040 0ustar0000000000000000{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Prim.Mid.Combinators where import Control.Monad ( join ) import Control.Monad.IO.Class ( liftIO ) import Reactive.Banana.Prim.Mid.Plumbing ( newPulse, newLatch, cachedLatch , dependOn, keepAlive, changeParent , getValueL , readPulseP, readLatchP, readLatchFutureP, liftBuildP, ) import qualified Reactive.Banana.Prim.Mid.Plumbing ( pureL ) import Reactive.Banana.Prim.Mid.Types ( Latch, Future, Pulse, Build, EvalP ) debug :: String -> a -> a -- debug s = trace s debug _ = id {----------------------------------------------------------------------------- Combinators - basic ------------------------------------------------------------------------------} mapP :: (a -> b) -> Pulse a -> Build (Pulse b) mapP f p1 = do p2 <- newPulse "mapP" ({-# SCC mapP #-} fmap f <$> readPulseP p1) p2 `dependOn` p1 return p2 -- | Tag a 'Pulse' with future values of a 'Latch'. -- -- This is in contrast to 'applyP' which applies the current value -- of a 'Latch' to a pulse. tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a)) tagFuture x p1 = do p2 <- newPulse "tagFuture" $ fmap . const <$> readLatchFutureP x <*> readPulseP p1 p2 `dependOn` p1 return p2 filterJustP :: Pulse (Maybe a) -> Build (Pulse a) filterJustP p1 = do p2 <- newPulse "filterJustP" ({-# SCC filterJustP #-} join <$> readPulseP p1) p2 `dependOn` p1 return p2 unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b) unsafeMapIOP f p1 = do p2 <- newPulse "unsafeMapIOP" ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1) p2 `dependOn` p1 return p2 where eval :: Maybe a -> EvalP (Maybe b) eval (Just x) = Just <$> liftIO (f x) eval Nothing = return Nothing mergeWithP :: (a -> Maybe c) -> (b -> Maybe c) -> (a -> b -> Maybe c) -> Pulse a -> Pulse b -> Build (Pulse c) mergeWithP f g h px py = do p <- newPulse "mergeWithP" ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py) p `dependOn` px p `dependOn` py return p where eval Nothing Nothing = Nothing eval (Just x) Nothing = f x eval Nothing (Just y) = g y eval (Just x) (Just y) = h x y -- See note [LatchRecursion] applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) applyP f x = do p <- newPulse "applyP" ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x) p `dependOn` x return p pureL :: a -> Latch a pureL = Reactive.Banana.Prim.Mid.Plumbing.pureL -- specialization of mapL f = applyL (pureL f) mapL :: (a -> b) -> Latch a -> Latch b mapL f lx = cachedLatch ({-# SCC mapL #-} f <$> getValueL lx) applyL :: Latch (a -> b) -> Latch a -> Latch b applyL lf lx = cachedLatch ({-# SCC applyL #-} getValueL lf <*> getValueL lx) accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) accumL a p1 = do (updateOn, x) <- newLatch a p2 <- newPulse "accumL" $ do a <- readLatchP x f <- readPulseP p1 return $ fmap (\g -> g a) f p2 `dependOn` p1 updateOn p2 return (x,p2) -- specialization of accumL stepperL :: a -> Pulse a -> Build (Latch a) stepperL a p = do (updateOn, x) <- newLatch a updateOn p return x {----------------------------------------------------------------------------- Combinators - dynamic event switching ------------------------------------------------------------------------------} switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a) switchL l pl = mdo x <- stepperL l pl return $ cachedLatch $ getValueL x >>= getValueL executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a) executeP p1 b = do p2 <- newPulse "executeP" ({-# SCC executeP #-} eval =<< readPulseP p1) p2 `dependOn` p1 return p2 where eval :: Maybe (b -> Build a) -> EvalP (Maybe a) eval (Just x) = Just <$> liftBuildP (x b) eval Nothing = return Nothing switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a) switchP p pp = do -- track the latest Pulse in a Latch lp <- stepperL p pp -- fetch the latest Pulse value pout <- newPulse "switchP_out" (readPulseP =<< readLatchP lp) let -- switch the Pulse `pout` to a new parent, -- keeping track of the new dependencies. switch = do mnew <- readPulseP pp case mnew of Nothing -> pure () Just new -> liftBuildP $ pout `changeParent` new pure Nothing pin <- newPulse "switchP_in" switch :: Build (Pulse ()) pin `dependOn` pp pout `dependOn` p -- initial dependency pout `keepAlive` pin -- keep switches happening pure pout reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Compile.hs0000644000000000000000000001013007346545000022134 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Evaluation.hs0000644000000000000000000001134207346545000022661 0ustar0000000000000000{-# 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 } reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/IO.hs0000644000000000000000000000372207346545000021064 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Plumbing.hs0000644000000000000000000002051707346545000022333 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Test.hs0000644000000000000000000000245407346545000021475 0ustar0000000000000000{-# LANGUAGE RecursiveDo #-} {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Prim.Mid.Test where import Reactive.Banana.Prim.Mid main :: IO () main = test_space1 {----------------------------------------------------------------------------- Functionality tests ------------------------------------------------------------------------------} test_accumL1 :: Pulse Int -> BuildIO (Pulse Int) test_accumL1 p1 = liftBuild $ do p2 <- mapP (+) p1 (l1,_) <- accumL 0 p2 let l2 = mapL const l1 applyP l2 p1 test_recursion1 :: Pulse () -> BuildIO (Pulse Int) test_recursion1 p1 = liftBuild $ mdo p2 <- applyP l2 p1 p3 <- mapP (const (+1)) p2 ~(l1,_) <- accumL (0::Int) p3 let l2 = mapL const l1 return p2 -- test garbage collection {----------------------------------------------------------------------------- Space leak tests ------------------------------------------------------------------------------} test_space1 :: IO () test_space1 = runSpaceProfile test_accumL1 [1::Int .. 2 * 10 ^ (4 :: Int)] test_space2 :: IO () test_space2 = runSpaceProfile test_recursion1 $ () <$ [1::Int .. 2 * 10 ^ (4 :: Int)] reactive-banana-1.3.2.0/src/Reactive/Banana/Prim/Mid/Types.hs0000644000000000000000000001575207346545000021667 0ustar0000000000000000{-# 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`. -} reactive-banana-1.3.2.0/src/Reactive/Banana/Types.hs0000644000000000000000000002075007346545000020241 0ustar0000000000000000{-# language CPP #-} {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Types ( -- | Primitive types. Event(..), Behavior(..), Moment(..), MomentIO(..), MonadMoment(..), Future(..), ) where import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Fix import Data.String (IsString(..)) import Control.Monad.Trans.Accum (AccumT) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.Maybe (MaybeT) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST) import Control.Monad.Trans.Reader (ReaderT) import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT) import qualified Control.Monad.Trans.State.Strict as Strict (StateT) import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT) import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as CPS (RWST) import qualified Control.Monad.Trans.Writer.CPS as CPS (WriterT) #endif import qualified Reactive.Banana.Prim.High.Combinators as Prim {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} {-| @Event a@ represents a stream of events as they occur in time. Semantically, you can think of @Event a@ as an infinite list of values that are tagged with their corresponding time of occurrence, > type Event a = [(Time,a)] Each pair is called an /event occurrence/. Note that within a single event stream, no two event occurrences may happen at the same time. <> -} newtype Event a = E { unE :: Prim.Event a } -- Invariant: The empty list `[]` never occurs as event value. -- | The function 'fmap' applies a function @f@ to every value. -- Semantically, -- -- > fmap :: (a -> b) -> Event a -> Event b -- > fmap f e = [(time, f a) | (time, a) <- e] instance Functor Event where fmap f = E . Prim.mapE f . unE -- | The combinator '<>' merges two event streams of the same type. -- In case of simultaneous occurrences, -- the events are combined with the underlying 'Semigroup' operation. -- Semantically, -- -- > (<>) :: Event a -> Event a -> Event a -- > (<>) ex ey = unionWith (<>) ex ey instance Semigroup a => Semigroup (Event a) where x <> y = E $ Prim.mergeWith id id (<>) (unE x) (unE y) -- | The combinator 'mempty' represents an event that never occurs. -- It is a synonym, -- -- > mempty :: Event a -- > mempty = never instance Semigroup a => Monoid (Event a) where mempty = E Prim.never mappend = (<>) {-| @Behavior a@ represents a value that varies in time. Semantically, you can think of it as a function > type Behavior a = Time -> a <> -} newtype Behavior a = B { unB :: Prim.Behavior a } -- | The function 'pure' returns a value that is constant in time. Semantically, -- -- > pure :: a -> Behavior a -- > pure x = \time -> x -- -- The combinator '<*>' applies a time-varying function to a time-varying value. -- -- > (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b -- > fx <*> bx = \time -> fx time $ bx time instance Applicative Behavior where pure x = B $ Prim.pureB x bf <*> bx = B $ Prim.applyB (unB bf) (unB bx) -- | The function 'fmap' applies a function @f@ at every point in time. -- Semantically, -- -- > fmap :: (a -> b) -> Behavior a -> Behavior b -- > fmap f b = \time -> f (b time) instance Functor Behavior where fmap = liftA instance Semigroup a => Semigroup (Behavior a) where (<>) = liftA2 (<>) instance (Semigroup a, Monoid a) => Monoid (Behavior a) where mempty = pure mempty mappend = (<>) instance Num a => Num (Behavior a) where (+) = liftA2 (+) (-) = liftA2 (-) (*) = liftA2 (*) abs = fmap abs signum = fmap signum fromInteger = pure . fromInteger negate = fmap negate instance Fractional a => Fractional (Behavior a) where (/) = liftA2 (/) fromRational = pure . fromRational recip = fmap recip instance Floating a => Floating (Behavior a) where (**) = liftA2 (**) acos = fmap acos acosh = fmap acosh asin = fmap asin asinh = fmap asinh atan = fmap atan atanh = fmap atanh cos = fmap cos cosh = fmap cosh exp = fmap exp log = fmap log logBase = liftA2 logBase pi = pure pi sin = fmap sin sinh = fmap sinh sqrt = fmap sqrt instance IsString a => IsString (Behavior a) where fromString = pure . fromString -- | The 'Future' monad is just a helper type for the 'changes' function. -- -- A value of type @Future a@ is only available in the context -- of a 'reactimate' but not during event processing. newtype Future a = F { unF :: Prim.Future a } -- boilerplate class instances instance Functor Future where fmap f = F . fmap f . unF instance Monad Future where m >>= g = F $ unF m >>= unF . g instance Applicative Future where pure = F . pure f <*> a = F $ unF f <*> unF a {-| The 'Moment' monad denotes a /pure/ computation that happens at one particular moment in time. Semantically, it is a reader monad > type Moment a = Time -> a When run, the argument tells the time at which this computation happens. Note that in this context, /time/ really means to /logical time/. Of course, every calculation on a computer takes some amount of wall-clock time to complete. Instead, what is meant here is the time as it relates to 'Event's and 'Behavior's. We use the fiction that every calculation within the 'Moment' monad takes zero /logical time/ to perform. -} newtype Moment a = M { unM :: Prim.Moment a } {-| The 'MomentIO' monad is used to add inputs and outputs to an event network. -} newtype MomentIO a = MIO { unMIO :: Prim.Moment a } instance MonadIO MomentIO where liftIO = MIO . liftIO {-| An instance of the 'MonadMoment' class denotes a computation that happens at one particular moment in time. Unlike the 'Moment' monad, it need not be pure anymore. -} class MonadFix m => MonadMoment m where liftMoment :: Moment a -> m a instance MonadMoment Moment where liftMoment = id instance MonadMoment MomentIO where liftMoment = MIO . unM instance (MonadMoment m, Monoid w) => MonadMoment (AccumT w m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (ExceptT e m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (IdentityT m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (MaybeT m) where liftMoment = lift . liftMoment instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.RWST r w s m) where liftMoment = lift . liftMoment instance (MonadMoment m, Monoid w) => MonadMoment (Strict.RWST r w s m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (ReaderT r m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (Lazy.StateT s m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (Strict.StateT s m) where liftMoment = lift . liftMoment instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.WriterT w m) where liftMoment = lift . liftMoment instance (MonadMoment m, Monoid w) => MonadMoment (Strict.WriterT w m) where liftMoment = lift . liftMoment #if MIN_VERSION_transformers(0,5,6) instance MonadMoment m => MonadMoment (CPS.RWST r w s m) where liftMoment = lift . liftMoment instance MonadMoment m => MonadMoment (CPS.WriterT w m) where liftMoment = lift . liftMoment #endif -- boilerplate class instances instance Functor Moment where fmap f = M . fmap f . unM instance Monad Moment where m >>= g = M $ unM m >>= unM . g instance Applicative Moment where pure = M . pure f <*> a = M $ unM f <*> unM a instance MonadFix Moment where mfix f = M $ mfix (unM . f) instance Semigroup a => Semigroup (Moment a) where (<>) = liftA2 (<>) instance Monoid a => Monoid (Moment a) where mempty = pure mempty instance Functor MomentIO where fmap f = MIO . fmap f . unMIO instance Monad MomentIO where m >>= g = MIO $ unMIO m >>= unMIO . g instance Applicative MomentIO where pure = MIO . pure f <*> a = MIO $ unMIO f <*> unMIO a instance MonadFix MomentIO where mfix f = MIO $ mfix (unMIO . f) instance Semigroup a => Semigroup (MomentIO a) where (<>) = liftA2 (<>) instance Monoid a => Monoid (MomentIO a) where mempty = pure mempty reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/0000755000000000000000000000000007346545000020563 5ustar0000000000000000reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Combinators.hs0000644000000000000000000002002207346545000023373 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Plumbing.hs0000644000000000000000000000720707346545000022702 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/High/Space.hs0000644000000000000000000000636107346545000022160 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/0000755000000000000000000000000007346545000020445 5ustar0000000000000000reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Gen.hs0000644000000000000000000000520007346545000021507 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/Graph.hs0000644000000000000000000000604507346545000022047 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Low/GraphGC.hs0000644000000000000000000001061207346545000022254 0ustar0000000000000000{-# 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 reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Mid/0000755000000000000000000000000007346545000020415 5ustar0000000000000000reactive-banana-1.3.2.0/test/Reactive/Banana/Test/Mid/Space.hs0000644000000000000000000001010007346545000021774 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-1.3.2.0/test/0000755000000000000000000000000007346545000014043 5ustar0000000000000000reactive-banana-1.3.2.0/test/reactive-banana-tests.hs0000644000000000000000000000162207346545000020560 0ustar0000000000000000{----------------------------------------------------------------------------- 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 ] ] reactive-banana-1.3.2.0/test/space.hs0000644000000000000000000000227607346545000015501 0ustar0000000000000000{-# 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