diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,141 @@ Changelog for the `reactive-banana` package ------------------------------------------- +**Version 1.3.2.0** (2023-01-22) + +* Fixed multiple space leaks for dynamic event switching by completely redesigning low-level internals. Added automated tests on garbage collection and space leaks in order to make sure that the leaks stay fixed. [#261][], [#267][], [#268][] + + [#268]: https://github.com/HeinrichApfelmus/reactive-banana/pull/268 + [#267]: https://github.com/HeinrichApfelmus/reactive-banana/pull/267 + [#261]: https://github.com/HeinrichApfelmus/reactive-banana/issues/261 + +**Version 1.3.1.0** (2022-08-11) + +* Various internal performance improvements. [#257][], [#258][] +* Fix a space leak in dynamic event switching. [#256][] +* Reduce memory usage of `stepper`/`accumB`. [#260][] +* Prevent a deadlock if the network crashes when evaluating a `Behavior` or `Event`. [#262][] + + [#257]: https://github.com/HeinrichApfelmus/reactive-banana/pull/257 + [#258]: https://github.com/HeinrichApfelmus/reactive-banana/pull/258 + [#256]: https://github.com/HeinrichApfelmus/reactive-banana/pull/256 + [#262]: https://github.com/HeinrichApfelmus/reactive-banana/pull/262 + [#260]: https://github.com/HeinrichApfelmus/reactive-banana/pull/260 + +**Version 1.3.0.0** (2022-03-28) + +* Added `Semigroup` and `Monoid` instances to `Moment` and `MomentIO`. [#223][] +* Add `@>` operator. [#229][] +* `switchE` now takes an initial event. This is breaking change. The previous behavior can be restored by using `switchE never`. [#165][] +* Triggering an `AddHandler` no longer allocates, leading to a minor performance improvement. [#237][] +* A new `once` combinator has been added that filters an `Event` so it only fires once. [#239][] +* `MonadMoment` instances have been added for all possibly monad transformers (from the `transformers` library). [#248][] +* Some internal refactoring to reduce allocations and improve performance. [#238][] +* The `Reactive.Banana.Prim` hierarchy has been changed to better reflect the abstraction hierarchy. [#241][] + + [#165]: https://github.com/HeinrichApfelmus/reactive-banana/pull/165 + [#229]: https://github.com/HeinrichApfelmus/reactive-banana/pull/229 + [#223]: https://github.com/HeinrichApfelmus/reactive-banana/pull/223 + [#237]: https://github.com/HeinrichApfelmus/reactive-banana/pull/237 + [#238]: https://github.com/HeinrichApfelmus/reactive-banana/pull/238 + [#239]: https://github.com/HeinrichApfelmus/reactive-banana/pull/239 + [#241]: https://github.com/HeinrichApfelmus/reactive-banana/pull/241 + [#248]: https://github.com/HeinrichApfelmus/reactive-banana/pull/248 + +**Version 1.2.2.0** + +* Optimize the implementation of `Graph.listParents` [#209][] +* Replace a use of `foldl` with `foldl'`. [#212][] +* Simplify the internal `mkWeakIORef` function. [#154][] +* Add `merge` and `mergeWith` combinators. [#163][], [#220][] +* Make internal SCC pragmas compatible with the GHC 9.0 parser. [#208][] +* Change `insertWith (flip (++))` to `insertWith (++)` in `insertEdge`. [#211][] +* Add `Semigroup a => Semigroup (Behavior a)` and `Monoid a => Monoid (Behavior a)` instances. [#185][] +* Loosen the upper-bound for `hashable` and `semigroups`. [#205][] + + [#154]: https://github.com/HeinrichApfelmus/reactive-banana/pull/154 + [#163]: https://github.com/HeinrichApfelmus/reactive-banana/pull/163 + [#185]: https://github.com/HeinrichApfelmus/reactive-banana/pull/185 + [#205]: https://github.com/HeinrichApfelmus/reactive-banana/pull/205 + [#208]: https://github.com/HeinrichApfelmus/reactive-banana/pull/208 + [#209]: https://github.com/HeinrichApfelmus/reactive-banana/pull/209 + [#211]: https://github.com/HeinrichApfelmus/reactive-banana/pull/211 + [#212]: https://github.com/HeinrichApfelmus/reactive-banana/pull/212 + [#220]: https://github.com/HeinrichApfelmus/reactive-banana/pull/219 + +**version 1.2.1.0** + +* Add `Num`, `Floating`, `Fractional`, and `IsString` instances for `Behavior`. [#34][] +* Support `containers-0.6`. [#191][] + + [#34]: https://github.com/HeinrichApfelmus/reactive-banana/pull/34 + [#191]: https://github.com/HeinrichApfelmus/reactive-banana/pull/191 + +**version 1.2.0.0** + +* Make `MonadFix` superclass of `MonadMoment`. [#128][] +* Add `Semigroup` and `Monoid` instances for `Event`. [#104][] +* Semigroup compatibility with GHC 8.4.1 [#168][] +* Increased upper-bound on `pqueue`. + + [#128]: https://github.com/HeinrichApfelmus/reactive-banana/pull/128 + [#104]: https://github.com/HeinrichApfelmus/reactive-banana/issues/104 + [#168]: https://github.com/HeinrichApfelmus/reactive-banana/pull/168 + +**version 1.1.0.1** + +* Adapt library to work with GHC-8.0.1. + +**version 1.1.0.0** + +* Fix bug: Types of `switchB` and `switchE` need to be in the `Moment` monad. +* Clean up and simplify model implementation in the `Reactive.Banana.Model` module. +* Update type signatures of the `interpret*` functions to make it easier to try FRP functions in the REPL. +* Remove `showNetwork` function. + +**version 1.0.0.1** + +* Improve documentation. + * Add prose section on recursion. + * Improve explanation for the `changes` function. +* Bump `transfomers` dependency. +* Remove defunct `UseExtensions` flag from cabal file. + +**version 1.0.0.0** + +The API has been redesigned significantly in this version! + +* Remove phantom type parameter `t` from `Event`, `Behavior` and `Moment` types. + * Change accumulation functions (`accumB`, `accumE`, `stepper`) to have a monadic result type. + * Merge module `Reactive.Banana.Switch` into module `Reactive.Banana.Combinators`. + * Simplify types of the switching functions (`switchE`, `switchB`, `observeB`, `execute`). + * Remove functions `trimE` and `trimB`. + * Remove types `AnyMoment` and `Identity`. +* Remove `Frameworks` class constraint, use `MomentIO` type instead. + * Add class `MonadMoment` for both polymorphism over the `Moment` and `MomentIO` types. +* Change type `Event` to only allow a single event per moment in time. + * Remove function `union`. Use `unionWith` instead. + * Change function `unions` to only merge events of type `Event (a -> a)`. +* Remove module `Reactive.Banana.Experimental.Calm`. +* Change the model implementation in the module `Reactive.Banana.Model` to the new API as well. + +Other changes: + +* Add `mapEventIO` utility function to build an Event that contains the result of an IO computation. +* Add `newBehavior` utility function to build a Behavior that can be updated with a `Handler`. +* Add illustrations to the API documentation. + +**version 0.9.0.0** + +* Implement garbage collection for dynamically switched events. +* Fix issue [#79][] where recursive declarations would sometimes result in dropped events. +* Limit value recursion in the `Moment` monad slightly. +* Change `initial` and `valueB` to behave subtly different when it comes to value recursion in the `Moment` monad. +* Add `Functor`, `Applicative` and `Monad` instances for the `FrameworksMoment` type. +* Depend on the [pqueue][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC. + + [#79]: https://github.com/HeinrichApfelmus/reactive-banana/issues/79 + **version 0.8.1.2** * Depend on the [psqueues][] package instead of the [pqueue][] package for the priority queue. @@ -20,7 +155,7 @@ **version 0.8.0.4** -* Just a reupload. The previous archive was broken. +* Just a re-upload. The previous archive was broken. **version 0.8.0.3** @@ -71,7 +206,7 @@ * Remove general `Monoid` instance for `Event` to simplify reasoning about simultaneous events. * Add `initial` and `changes` combinators that allow you to observe updates to `Behavior`. Remove the `Reactive.Banana.Incremental` module. * Rename most modules, -* Change type singaturs: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type. +* Change type signatures: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type. **version 0.4.3.1** diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2011, Heinrich Apfelmus +Copyright (c)2011-2015, Heinrich Apfelmus All rights reserved. diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NumericUnderscores #-} +module Main ( main ) where + +import Control.Monad (replicateM, replicateM_, forM_) +import qualified Data.IntMap.Strict as IM +import Reactive.Banana.Combinators ( Event, Behavior, MonadMoment, filterE, accumE, switchB, accumB ) +import Reactive.Banana.Frameworks (MomentIO, newAddHandler, fromAddHandler, compile, actuate, Handler, reactimate) +import Reactive.Banana ( Event, Behavior, MonadMoment ) +import System.Random (randomRIO) +import Test.Tasty (withResource) +import Test.Tasty.Bench (env, defaultMain, bgroup, bench, whnfIO) + +main :: IO () +main = defaultMain $ [ mkBenchmarkGroup netsize | netsize <- [ 1, 2, 4, 8, 16, 32, 64, 128 ] ] ++ + [ boringBenchmark ] + where + mkBenchmarkGroup netsize = + withResource (setupBenchmark netsize) mempty $ \getEnv -> + bgroup ("netsize = " <> show netsize) + [ mkBenchmark getEnv steps | steps <- [ 1, 2, 4, 8, 16, 32, 64, 128] ] + where + mkBenchmark getEnv duration = bench ("duration = " <> show duration) $ whnfIO $ do + (triggers, clock) <- getEnv + let trigMap = IM.fromList $ zip [0..netsize-1] triggers + forM_ [1..duration] $ \step -> do + randomRs <- replicateM 10 $ randomRIO (0,netsize-1) + clock step + forM_ randomRs $ \ev -> + maybe (error "benchmark: trigger not found") ($ ()) $ + IM.lookup ev trigMap + + boringBenchmark = withResource setup mempty $ \getEnv -> + bench "Boring" $ whnfIO $ do + tick <- getEnv + {-# SCC ticks #-} replicateM_ 1_000_000 $ {-# SCC tick #-} tick () + where + setup = do + (tick, onTick) <- newAddHandler + network <- compile $ do + e <- fromAddHandler tick + reactimate $ return <$> e + actuate network + return onTick + +setupBenchmark :: Int -> IO ([Handler ()], Handler Int) +setupBenchmark netsize = do + (handlers, triggers) <- unzip <$> replicateM netsize newAddHandler + (clock , trigger ) <- newAddHandler + + let networkD :: MomentIO () + networkD = do + es :: [Event ()] <- + mapM fromAddHandler handlers + + e :: Event Int <- + fromAddHandler clock + + countBs :: [Behavior Int] <- + traverse count es + + let + step10E :: Event Int + step10E = filterE (\cnt -> cnt `rem` 10 == 0) e + + selectedB_E :: Event (Behavior Int) <- do + fmap head <$> accumE countBs (keepTail <$ step10E) + + selectedB :: Behavior Int <- + switchB (head countBs) selectedB_E + + return () + + count :: MonadMoment m => Event () -> m (Behavior Int) + count e = accumB 0 ((+1) <$ e) + + actuate =<< compile networkD + return (triggers, trigger) + where + keepTail :: [a] -> [a] + keepTail (_:y:zs) = y:zs + keepTail [x] = [x] + keepTail [] = [] diff --git a/doc/examples/ActuatePause.hs b/doc/examples/ActuatePause.hs --- a/doc/examples/ActuatePause.hs +++ b/doc/examples/ActuatePause.hs @@ -71,7 +71,7 @@ ecounter <- fromAddHandler (addHandler escounter) epause <- fromAddHandler (addHandler espause ) - let ecount = accumE 0 ((+1) <$ ecounter) + ecount <- accumE 0 $ (+1) <$ ecounter reactimate $ fmap print ecount reactimate $ fmap pause epause diff --git a/doc/examples/Counter.hs b/doc/examples/Counter.hs --- a/doc/examples/Counter.hs +++ b/doc/examples/Counter.hs @@ -70,7 +70,10 @@ counterDown <- fromAddHandler (addHandler eminus) epause <- fromAddHandler (addHandler espause) - let ecount = accumE 0 $ ((+1) <$ counterUp) `union` (subtract 1 <$ counterDown) + ecount <- accumE 0 $ unions + [ (+1) <$ counterUp + , subtract 1 <$ counterDown + ] reactimate $ fmap print ecount reactimate $ fmap pause epause diff --git a/doc/examples/Octave.hs b/doc/examples/Octave.hs --- a/doc/examples/Octave.hs +++ b/doc/examples/Octave.hs @@ -1,17 +1,22 @@ {----------------------------------------------------------------------------- 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 Data.Char (toUpper) import Control.Monad (forever) -import System.IO (BufferMode(..), hSetEcho, hSetBuffering, stdin) +import System.IO (BufferMode(..), hSetEcho, hSetBuffering, stdin) + import Reactive.Banana -import Reactive.Banana.Prim (addHandler) import Reactive.Banana.Frameworks @@ -40,7 +45,7 @@ show (Note o p) = show p ++ show o -- Filter and transform events at the same time. -filterMapJust :: (a -> Maybe b) -> Event t a -> Event t b +filterMapJust :: (a -> Maybe b) -> Event a -> Event b filterMapJust f = filterJust . fmap f -- Change the original octave by adding a number of octaves, taking @@ -55,16 +60,20 @@ '-' -> Just (-1) _ -> Nothing -makeNetworkDescription :: Frameworks t => AddHandler Char -> Moment t () +makeNetworkDescription :: AddHandler Char -> MomentIO () makeNetworkDescription addKeyEvent = do eKey <- fromAddHandler addKeyEvent + + let eOctaveChange = filterMapJust getOctaveChange eKey + bOctave <- accumB 3 (changeOctave <$> eOctaveChange) + + let ePitch = filterMapJust (`lookup` charPitches) eKey + bPitch <- stepper PC ePitch + let - eOctaveChange = filterMapJust getOctaveChange eKey - bOctave = accumB 3 (changeOctave <$> eOctaveChange) - ePitch = filterMapJust (`lookup` charPitches) eKey - bPitch = stepper PC ePitch bNote = Note <$> bOctave <*> bPitch foo = Note 0 PA + eNoteChanged <- changes bNote reactimate' $ fmap (\n -> putStrLn ("Now playing " ++ show n)) <$> eNoteChanged diff --git a/doc/examples/SlotMachine.hs b/doc/examples/SlotMachine.hs --- a/doc/examples/SlotMachine.hs +++ b/doc/examples/SlotMachine.hs @@ -3,7 +3,14 @@ Example: Slot machine ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Control.Monad (when) import Data.Maybe (isJust, fromJust) @@ -21,7 +28,7 @@ main = do displayHelpMessage sources <- makeSources - network <- compile $ setupNetwork sources + network <- compile $ networkDescription sources actuate network eventLoop sources @@ -79,10 +86,9 @@ data Win = Double | Triple --- Set up the program logic in terms of events and behaviors. -setupNetwork :: forall t. Frameworks t => - (EventSource (), EventSource ()) -> Moment t () -setupNetwork (escoin,esplay) = do +-- Program logic in terms of events and behaviors. +networkDescription :: (EventSource (), EventSource ()) -> MomentIO () +networkDescription (escoin,esplay) = mdo -- initial random number generator initialStdGen <- liftIO $ newStdGen @@ -90,20 +96,19 @@ ecoin <- fromAddHandler (addHandler escoin) eplay <- fromAddHandler (addHandler esplay) - let - -- The state of the slot machine is captured in Behaviors. - - -- State: credits that the player has to play the game - -- The ecoin event adds a coin to the credits - -- The edoesplay event removes money - -- The ewin event adds credits because the player has won - bcredits :: Behavior t Money - ecredits :: Event t Money - (ecredits, bcredits) = mapAccum 0 . fmap (\f x -> (f x,f x)) $ - ((addCredit <$ ecoin) - `union` (removeCredit <$ edoesplay) - `union` (addWin <$> ewin)) + -- The state of the slot machine is captured in Behaviors. + -- State: credits that the player has to play the game + -- The ecoin event adds a coin to the credits + -- The edoesplay event removes money + -- The ewin event adds credits because the player has won + (ecredits :: Event Money, bcredits :: Behavior Money) + <- mapAccum 0 . fmap (\f x -> (f x,f x)) $ unions $ + [ addCredit <$ ecoin + , removeCredit <$ edoesplay + , addWin <$> ewin + ] + let -- functions that change the accumulated state addCredit = (+1) removeCredit = subtract 1 @@ -111,34 +116,34 @@ addWin Triple = (+20) -- Event: does the player have enough money to play the game? - emayplay :: Event t Bool - emayplay = apply ((\credits _ -> credits > 0) <$> bcredits) eplay + emayplay :: Event Bool + emayplay = (\credits _ -> credits > 0) <$> bcredits <@> eplay -- Event: player has enough coins and plays - edoesplay :: Event t () + edoesplay :: Event () edoesplay = () <$ filterE id emayplay -- Event: event that fires when the player doesn't have enough money - edenied :: Event t () + edenied :: Event () edenied = () <$ filterE not emayplay - -- State: random number generator - bstdgen :: Behavior t StdGen - eroll :: Event t Reels + -- State: random number generator + (eroll :: Event Reels, bstdgen :: Behavior StdGen) -- accumulate the random number generator while rolling the reels - (eroll, bstdgen) = mapAccum initialStdGen (roll <$> edoesplay) - + <- mapAccum initialStdGen $ roll <$> edoesplay + + let -- roll the reels roll :: () -> StdGen -> (Reels, StdGen) roll () gen0 = ((z1,z2,z3),gen3) where - random = randomR(1,4) + random = randomR(1,4) (z1,gen1) = random gen0 (z2,gen2) = random gen1 (z3,gen3) = random gen2 -- Event: it's a win! - ewin :: Event t Win + ewin :: Event Win ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll checkWin (z1,z2,z3) | length (nub [z1,z2,z3]) == 1 = Just Triple @@ -157,6 +162,3 @@ showRoll (z1,z2,z3) = "You rolled " ++ show z1 ++ show z2 ++ show z3 showWin Double = "Wow, a double!" showWin Triple = "Wowwowow! A triple! So awesome!" - - - diff --git a/doc/frp-behavior.png b/doc/frp-behavior.png new file mode 100644 Binary files /dev/null and b/doc/frp-behavior.png differ diff --git a/doc/frp-event.png b/doc/frp-event.png new file mode 100644 Binary files /dev/null and b/doc/frp-event.png differ diff --git a/doc/frp-stepper.png b/doc/frp-stepper.png new file mode 100644 Binary files /dev/null and b/doc/frp-stepper.png differ diff --git a/reactive-banana.cabal b/reactive-banana.cabal --- a/reactive-banana.cabal +++ b/reactive-banana.cabal @@ -1,5 +1,5 @@ Name: reactive-banana -Version: 0.8.1.2 +Version: 1.3.2.0 Synopsis: Library for functional reactive programming (FRP). Description: Reactive-banana is a library for Functional Reactive Programming (FRP). @@ -9,18 +9,13 @@ See the project homepage for more detailed documentation and examples. . - /Stability forecast:/ - . - No semantic bugs expected. - . - Significant API changes are likely in future versions, - though the main interface is beginning to stabilize. - . - The library features an efficient, push-driven implementation + /Stability forecast./ + This is a stable library, though minor API changes are still likely. + It features an efficient, push-driven implementation and has seen some optimization work. - However, the inner loop still has a rather large constant factor overhead. - Moreover, there is currently /no/ garbage collection for events that are - created dynamically with @Reactive.Banana.Switch@. + . + /API guide./ + Start with the "Reactive.Banana" module. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3 @@ -28,82 +23,121 @@ Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus Category: FRP -Cabal-version: >= 1.9.2 +Cabal-version: 1.18 Build-type: Simple +Tested-with: GHC == 9.4.1 + , GHC == 9.2.4 + , GHC == 8.10.7 + , GHC == 8.8.4 + , GHC == 8.6.5 + , GHC == 8.4.4 extra-source-files: CHANGELOG.md, - doc/examples/*.hs, - src/Reactive/Banana/Test.hs, - src/Reactive/Banana/Test/Plumbing.hs + doc/examples/*.hs +extra-doc-files: doc/*.png Source-repository head type: git - location: git://github.com/HeinrichApfelmus/reactive-banana.git + location: https://github.com/HeinrichApfelmus/reactive-banana subdir: reactive-banana/ -flag UseExtensions - description: Use GHC-specific language extensions. - This enables the efficient push-driven implementation, - but doesn't necessarily work with compilers other than GHC. --- Cabal checks if the package can be build with UseExtensions = True, --- otherewise it is set to False . - Library + default-language: Haskell98 hs-source-dirs: src - - extensions: RecursiveDo, - Rank2Types, ScopedTypeVariables, - ExistentialQuantification, - TypeSynonymInstances, FlexibleInstances, - NoMonomorphismRestriction - - build-depends: base >= 4.2 && < 5, - containers >= 0.5 && < 0.6, - transformers >= 0.2 && < 0.5, - vault == 0.3.* - extensions: EmptyDataDecls, - BangPatterns - - build-depends: unordered-containers >= 0.2.1.0 && < 0.3, - hashable >= 1.1 && < 1.3, - psqueues >= 0.2 && < 0.3 + build-depends: base >= 4.2 && < 5, + deepseq >= 1.4.3.0 && < 1.5, + semigroups >= 0.13 && < 0.21, + containers >= 0.5 && < 0.7, + transformers >= 0.2 && < 0.7, + vault == 0.3.*, + unordered-containers >= 0.2.1.0 && < 0.3, + hashable >= 1.1 && < 1.5, + pqueue >= 1.0 && < 1.5, + stm >= 2.5 && < 2.6, + these >= 0.2 && < 1.2 --- CPP-options: -DUseExtensions - exposed-modules: Control.Event.Handler, Reactive.Banana, Reactive.Banana.Combinators, - Reactive.Banana.Experimental.Calm, Reactive.Banana.Frameworks, Reactive.Banana.Model, - Reactive.Banana.Prim, - Reactive.Banana.Prim.Cached, - Reactive.Banana.Switch - + Reactive.Banana.Prim.Mid, + Reactive.Banana.Prim.High.Cached, + Reactive.Banana.Prim.Low.Graph, + Reactive.Banana.Prim.Low.GraphGC, + Reactive.Banana.Prim.Low.Ref + other-modules: - Reactive.Banana.Internal.Combinators, - Reactive.Banana.Internal.Phantom, - Reactive.Banana.Prim.Combinators, - Reactive.Banana.Prim.Compile, - Reactive.Banana.Prim.Dated, - Reactive.Banana.Prim.Dependencies, - Reactive.Banana.Prim.Evaluation, - Reactive.Banana.Prim.IO, - Reactive.Banana.Prim.Order, - Reactive.Banana.Prim.Plumbing, - Reactive.Banana.Prim.Test, - Reactive.Banana.Prim.Types, + Control.Monad.Trans.ReaderWriterIO, + Control.Monad.Trans.RWSIO, + Reactive.Banana.Prim.Low.OrderedBag, + Reactive.Banana.Prim.Low.GraphTraversal, + Reactive.Banana.Prim.Mid.Combinators, + Reactive.Banana.Prim.Mid.Compile, + Reactive.Banana.Prim.Mid.Evaluation, + Reactive.Banana.Prim.Mid.IO, + Reactive.Banana.Prim.Mid.Plumbing, + Reactive.Banana.Prim.Mid.Test, + Reactive.Banana.Prim.Mid.Types, + Reactive.Banana.Prim.High.Combinators, Reactive.Banana.Types -Test-Suite tests + ghc-options: -Wall -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-fields -Werror=partial-fields -Wno-name-shadowing + +Test-Suite unit + default-language: Haskell98 type: exitcode-stdio-1.0 - hs-source-dirs: src - main-is: Reactive/Banana/Test.hs - build-depends: base >= 4.2 && < 5, - HUnit >= 1.2 && < 2, - test-framework >= 0.6 && < 0.9, - test-framework-hunit >= 0.2 && < 0.4, - reactive-banana, vault, containers, transformers, - unordered-containers, hashable, psqueues + hs-source-dirs: test + main-is: reactive-banana-tests.hs + other-modules: Reactive.Banana.Test.High.Combinators, + Reactive.Banana.Test.High.Plumbing, + Reactive.Banana.Test.High.Space, + Reactive.Banana.Test.Mid.Space, + Reactive.Banana.Test.Low.Gen, + Reactive.Banana.Test.Low.Graph, + Reactive.Banana.Test.Low.GraphGC + build-depends: base >= 4.7 && < 5, + containers, + deepseq >= 1.4.3.0 && < 1.5, + hashable, + pqueue, + reactive-banana, + semigroups, + transformers, + tasty, + tasty-hunit, + tasty-quickcheck >= 0.10.1.2 && < 0.11, + QuickCheck >= 2.10 && < 2.15, + unordered-containers, + vault, + these + +Benchmark space + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base + , reactive-banana + , tasty-quickcheck + , tasty + , QuickCheck + hs-source-dirs: test + main-is: space.hs + other-modules: Reactive.Banana.Test.Mid.Space + , Reactive.Banana.Test.High.Space + ghc-options: -rtsopts -eventlog + + +Benchmark benchmark + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base + , reactive-banana + , containers + , random + , tasty + , tasty-bench + hs-source-dirs: benchmark + main-is: Main.hs + ghc-options: "-with-rtsopts=-A32m" diff --git a/src/Control/Event/Handler.hs b/src/Control/Event/Handler.hs --- a/src/Control/Event/Handler.hs +++ b/src/Control/Event/Handler.hs @@ -2,19 +2,18 @@ -- * 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 -type Map = Map.Map - {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} @@ -22,12 +21,12 @@ -- /event value/ and performs some computation. type Handler a = a -> IO () --- | A value of type @Addhandler a@ is a facility for registering +-- | The type 'AddHandler' represents a facility for registering -- event handlers. These will be called whenever the event occurs. --- +-- -- When registering an event handler, you will also be given an action -- that unregisters this handler again. --- +-- -- > do unregisterMyHandler <- register addHandler myHandler -- newtype AddHandler a = AddHandler { register :: Handler a -> IO (IO ()) } @@ -40,12 +39,12 @@ -- | Map the event value with an 'IO' action. mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b -mapIO f e = AddHandler $ \h -> register e $ \x -> f x >>= h +mapIO f e = AddHandler $ \h -> register e (f >=> h) -- | Filter event values that don't return 'True'. filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a filterIO f e = AddHandler $ \h -> - register e $ \x -> f x >>= \b -> if b then h x else return () + register e $ \x -> f x >>= \b -> when b $ h x {----------------------------------------------------------------------------- Construction @@ -68,7 +67,29 @@ atomicModifyIORef_ handlers $ Map.insert key handler return $ atomicModifyIORef_ handlers $ Map.delete key runHandlers a = - mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers + runAll a =<< readIORef handlers return (AddHandler register, runHandlers) +atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ()) + +-- | A callback is a @a -> IO ()@ function. We define this newtype to provide +-- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which +-- allow us to write the efficient 'runAll' function. +newtype Callback a = Callback { invoke :: a -> IO () } + +instance Semigroup (Callback a) where + Callback f <> Callback g = Callback $ \a -> f a >> g a + +instance Monoid (Callback a) where + mempty = Callback $ \_ -> return () + +-- This function can also be seen as +-- +-- runAll a fs = mapM_ ($ a) fs +-- +-- The reason we write this using 'foldMap' and 'Callback' is to produce code +-- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237 +-- for more info. +runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO () +runAll a fs = invoke (foldMap Callback fs) a diff --git a/src/Control/Monad/Trans/RWSIO.hs b/src/Control/Monad/Trans/RWSIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/RWSIO.hs @@ -0,0 +1,87 @@ +module Control.Monad.Trans.RWSIO ( + -- * Synopsis + -- | An implementation of the reader/writer/state monad transformer + -- using an 'IORef'. + + -- * Documentation + RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put, + ) where + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef + +{----------------------------------------------------------------------------- + Type and class instances +------------------------------------------------------------------------------} +data Tuple r w s = Tuple !r !(IORef w) !(IORef s) + +newtype RWSIOT r w s m a = R { run :: Tuple r w s -> m a } + +instance Functor m => Functor (RWSIOT r w s m) where fmap = fmapR + +instance Applicative m => Applicative (RWSIOT r w s m) where + pure = pureR + (<*>) = apR + +instance Monad m => Monad (RWSIOT r w s m) where + (>>=) = bindR + +instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR +instance MonadIO m => MonadIO (RWSIOT r w s m) where liftIO = liftIOR +instance MonadTrans (RWSIOT r w s) where lift = liftR + +{----------------------------------------------------------------------------- + Functions +------------------------------------------------------------------------------} +liftIOR :: MonadIO m => IO a -> RWSIOT r w s m a +liftIOR m = R $ \_ -> liftIO m + +liftR :: m a -> RWSIOT r w s m a +liftR m = R $ \_ -> m + +fmapR :: Functor m => (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b +fmapR f m = R $ \x -> fmap f (run m x) + +bindR :: Monad m => RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b +bindR m k = R $ \x -> run m x >>= \a -> run (k a) x + +mfixR :: MonadFix m => (a -> RWSIOT r w s m a) -> RWSIOT r w s m a +mfixR f = R $ \x -> mfix (\a -> run (f a) x) + +pureR :: Applicative m => a -> RWSIOT r w s m a +pureR a = R $ \_ -> pure a + +apR :: Applicative m => RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b +apR f a = R $ \x -> run f x <*> run a x + +rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a +rwsT f = do + r <- ask + s <- get + (a,s,w) <- liftIOR $ f r s + put s + tell w + return a + +runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w)) +runRWSIOT m r s = do + w' <- liftIO $ newIORef mempty + s' <- liftIO $ newIORef s + a <- run m (Tuple r w' s') + s <- liftIO $ readIORef s' + w <- liftIO $ readIORef w' + return (a,s,w) + +tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m () +tell w = R $ \(Tuple _ w' _) -> liftIO $ modifyIORef w' (`mappend` w) + +ask :: Monad m => RWSIOT r w s m r +ask = R $ \(Tuple r _ _) -> return r + +get :: MonadIO m => RWSIOT r w s m s +get = R $ \(Tuple _ _ s') -> liftIO $ readIORef s' + +put :: MonadIO m => s -> RWSIOT r w s m () +put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s diff --git a/src/Control/Monad/Trans/ReaderWriterIO.hs b/src/Control/Monad/Trans/ReaderWriterIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/ReaderWriterIO.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TypeFamilies #-} +module Control.Monad.Trans.ReaderWriterIO ( + -- * Synopsis + -- | An implementation of the reader/writer monad transformer + -- using an 'IORef' for the writer. + + -- * Documentation + ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local, + ) where + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef + +{----------------------------------------------------------------------------- + Type and class instances +------------------------------------------------------------------------------} +newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a } + +instance Functor m => Functor (ReaderWriterIOT r w m) where fmap = fmapR + +instance Applicative m => Applicative (ReaderWriterIOT r w m) where + pure = pureR + (<*>) = apR + +instance Monad m => Monad (ReaderWriterIOT r w m) where + (>>=) = bindR + +instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR +instance MonadIO m => MonadIO (ReaderWriterIOT r w m) where liftIO = liftIOR +instance MonadTrans (ReaderWriterIOT r w) where lift = liftR + +instance (Monad m, a ~ ()) => Semigroup (ReaderWriterIOT r w m a) where + mx <> my = mx >> my + +instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where + mempty = return () + mappend = (<>) + +{----------------------------------------------------------------------------- + Functions +------------------------------------------------------------------------------} +liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a +liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m + +liftR :: m a -> ReaderWriterIOT r w m a +liftR m = ReaderWriterIOT $ \_ _ -> m + +fmapR :: Functor m => (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b +fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y) + +bindR :: Monad m => ReaderWriterIOT r w m a -> (a -> ReaderWriterIOT r w m b) -> ReaderWriterIOT r w m b +bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y + +mfixR :: MonadFix m => (a -> ReaderWriterIOT r w m a) -> ReaderWriterIOT r w m a +mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y) + +pureR :: Applicative m => a -> ReaderWriterIOT r w m a +pureR a = ReaderWriterIOT $ \_ _ -> pure a + +apR :: Applicative m => ReaderWriterIOT r w m (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b +apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y + +readerWriterIOT :: (MonadIO m, Monoid w) => + (r -> IO (a, w)) -> ReaderWriterIOT r w m a +readerWriterIOT f = do + r <- ask + (a,w) <- liftIOR $ f r + tell w + return a + +runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w) +runReaderWriterIOT m r = do + ref <- liftIO $ newIORef mempty + a <- run m r ref + w <- liftIO $ readIORef ref + return (a,w) + +tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m () +tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w) + +listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w) +listen m = ReaderWriterIOT $ \r ref -> do + a <- run m r ref + w <- liftIO $ readIORef ref + return (a,w) + +local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a +local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref + +ask :: Monad m => ReaderWriterIOT r w m r +ask = ReaderWriterIOT $ \r _ -> return r diff --git a/src/Reactive/Banana.hs b/src/Reactive/Banana.hs --- a/src/Reactive/Banana.hs +++ b/src/Reactive/Banana.hs @@ -1,16 +1,43 @@ {----------------------------------------------------------------------------- - Reactive Banana - - A small library for functional reactive programming. + reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana ( + -- * Synopsis + -- | Reactive-banana is a library for functional reactive programming (FRP). + -- To use it, import this module: + -- + -- > import Reactive.Banana + + -- * Overview + -- $intro + + -- * Exports module Reactive.Banana.Combinators, - module Reactive.Banana.Switch, compile, ) where import Reactive.Banana.Combinators import Reactive.Banana.Frameworks -import Reactive.Banana.Types -import Reactive.Banana.Switch + +{-$intro + +The module "Reactive.Banana.Combinators" collects the key types +and concepts of FRP. You will spend most of your time with this module. + +The module "Reactive.Banana.Model" is /not/ used in practice. +It contains an easy-to-understand model re-implementation of the FRP API. +This is useful for learning FRP and for internal testing purposes. + +The module "Reactive.Banana.Frameworks" allows you to connect +the FRP types and combinators to the outside world (IO). +If you are /using/ an existing binding like reactive-banana-wx, +then you probably won't need this module very often. +On the other hand, if you are /writing/ a binding to an external +library, then you will definitely need this. + +The module hierarchy at "Reactive.Banana.Prim" +implements the efficient low-level FRP engine that powers the rest of the library. +This is only useful if you want to implement your own FRP library. + +-} diff --git a/src/Reactive/Banana/Combinators.hs b/src/Reactive/Banana/Combinators.hs --- a/src/Reactive/Banana/Combinators.hs +++ b/src/Reactive/Banana/Combinators.hs @@ -2,315 +2,404 @@ reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE MultiParamTypeClasses #-} module Reactive.Banana.Combinators ( -- * Synopsis - -- | Combinators for building event graphs. - - -- * Introduction - -- $intro1 + -- $synopsis + + -- * Core Combinators + -- ** Event and Behavior Event, Behavior, - -- $intro2 interpret, - - -- * Core Combinators + + -- ** First-order + -- | This subsections lists the primitive first-order combinators for FRP. + -- The 'Functor', 'Applicative' and 'Monoid' instances are also part of this, + -- but they are documented at the types 'Event' and 'Behavior'. module Control.Applicative, - module Data.Monoid, - never, union, unions, filterE, collect, spill, accumE, - apply, stepper, - -- $classes - + module Data.Semigroup, + never, unionWith, filterE, + apply, + + -- ** Moment and accumulation + Moment, MonadMoment(..), + accumE, stepper, + + -- ** Recursion + -- $recursion + + -- ** Higher-order + valueB, valueBLater, observeE, switchE, switchB, + -- * Derived Combinators -- ** Infix operators - (<@>), (<@), + (<@>), (<@), (@>), -- ** Filtering - filterJust, filterApply, whenE, split, + filterJust, filterApply, whenE, split, once, -- ** Accumulation -- $Accumulation. - accumB, mapAccum, - -- ** Simultaneous event occurrences - calm, unionWith, + unions, accumB, mapAccum, + -- ** Merging events + merge, mergeWith ) where import Control.Applicative -import Control.Monad -import Data.Maybe (isJust, catMaybes) -import Data.Monoid (Monoid(..)) +import Data.Semigroup +import Data.These (These(..)) -import qualified Reactive.Banana.Internal.Combinators as Prim +import qualified Reactive.Banana.Prim.High.Combinators as Prim import Reactive.Banana.Types {----------------------------------------------------------------------------- Introduction ------------------------------------------------------------------------------} -{-$intro1 +{-$synopsis -At its core, Functional Reactive Programming (FRP) is about two -data types 'Event' and 'Behavior' and the various ways to combine them. +The main types and combinators of Functional Reactive Programming (FRP). +At its core, FRP is about two data types 'Event' and 'Behavior' +and the various ways to combine them. +There is also a third type 'Moment', +which is necessary for the higher-order combinators. + -} -- Event -- Behavior -{-$intro2 - -As you can see, both types seem to have a superfluous parameter @t@. -The library uses it to rule out certain gross inefficiencies, -in particular in connection with dynamic event switching. -For basic stuff, you can completely ignore it, -except of course for the fact that it will annoy you in your type signatures. - -While the type synonyms mentioned above are the way you should think about -'Behavior' and 'Event', they are a bit vague for formal manipulation. -To remedy this, the library provides a very simple but authoritative -model implementation. See "Reactive.Banana.Model" for more. - --} - {----------------------------------------------------------------------------- Interpetation ------------------------------------------------------------------------------} -- | Interpret an event processing function. -- Useful for testing. -interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] -interpret f xs = - map toList <$> Prim.interpret (return . unE . f . E) (map Just xs) - -toList :: Maybe [a] -> [a] -toList Nothing = [] -toList (Just xs) = xs +-- +-- Note: You can safely assume that this function is pure, +-- even though the type seems to suggest otherwise. +-- I'm really sorry about the extra 'IO', but it can't be helped. +-- See source code for the sordid details. +interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] +interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs +-- FIXME: I would love to remove the 'IO' from the type signature, +-- but unfortunately, it is possible that the argument to interpret +-- returns an Event that was created in the context of an existing network, e.g. +-- +-- > eBad <- fromAddHandler ... +-- > ... +-- > let ys = interpret (\_ -> return eBad ) xs +-- +-- Doing this is a big no-no and will break a lot of things, +-- but if we remove the 'IO' here, then we will also break referential +-- transparency, and I think that takes it too far. {----------------------------------------------------------------------------- Core combinators ------------------------------------------------------------------------------} -singleton :: a -> [a] -singleton x = [x] - -- | Event that never occurs. --- Think of it as @never = []@. -never :: Event t a -never = E $ Prim.mapE singleton Prim.never +-- Semantically, +-- +-- > never = [] +never :: Event a +never = E Prim.never -- | Merge two event streams of the same type. --- In case of simultaneous occurrences, the left argument comes first. --- Think of it as +-- The function argument specifies how event values are to be combined +-- in case of a simultaneous occurrence. The semantics are -- --- > union ((timex,x):xs) ((timey,y):ys) --- > | timex <= timey = (timex,x) : union xs ((timey,y):ys) --- > | timex > timey = (timey,y) : union ((timex,x):xs) ys -union :: Event t a -> Event t a -> Event t a -union e1 e2 = E $ Prim.unionWith (++) (unE e1) (unE e2) +-- > unionWith f ((timex,x):xs) ((timey,y):ys) +-- > | timex < timey = (timex,x) : unionWith f xs ((timey,y):ys) +-- > | timex > timey = (timey,y) : unionWith f ((timex,x):xs) ys +-- > | timex == timey = (timex,f x y) : unionWith f xs ys +unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a +unionWith f = mergeWith id id f --- | Merge several event streams of the same type. --- --- > unions = foldr union never -unions :: [Event t a] -> Event t a -unions = foldr union never +-- | Merge two event streams of any type. +merge :: Event a -> Event b -> Event (These a b) +merge = mergeWith This That These +-- | Merge two event streams of any type. +-- +-- This function generalizes 'unionWith'. +mergeWith + :: (a -> c) -- ^ The function called when only the first event emits a value. + -> (b -> c) -- ^ The function called when only the second event emits a value. + -> (a -> b -> c) -- ^ The function called when both events emit values simultaneously. + -> Event a + -> Event b + -> Event c +mergeWith f g h e1 e2 = E $ Prim.mergeWith f g h (unE e1) (unE e2) + -- | Allow all event occurrences that are 'Just' values, discard the rest. -- Variant of 'filterE'. -filterJust :: Event t (Maybe a) -> Event t a -filterJust = E . Prim.filterJust . Prim.mapE (decide . catMaybes) . unE - where - decide xs = if null xs then Nothing else Just xs +filterJust :: Event (Maybe a) -> Event a +filterJust = E . Prim.filterJust . unE -- | Allow all events that fulfill the predicate, discard the rest. --- Think of it as --- +-- Semantically, +-- -- > filterE p es = [(time,a) | (time,a) <- es, p a] -filterE :: (a -> Bool) -> Event t a -> Event t a +filterE :: (a -> Bool) -> Event a -> Event a filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing) --- | Collect simultaneous event occurences. --- The result will never contain an empty list. --- Example: +-- | Apply a time-varying function to a stream of events. +-- Semantically, -- --- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])] -collect :: Event t a -> Event t [a] -collect e = E $ Prim.mapE singleton (unE e) +-- > apply bf ex = [(time, bf time x) | (time, x) <- ex] +-- +-- This function is generally used in its infix variant '<@>'. +apply :: Behavior (a -> b) -> Event a -> Event b +apply bf ex = E $ Prim.applyE (unB bf) (unE ex) --- | Emit simultaneous event occurrences. --- The first element in the list will be emitted first, and so on. +-- | Construct a time-varying function from an initial value and +-- a stream of new values. The result will be a step function. +-- Semantically, -- --- Up to strictness, we have +-- > stepper x0 ex = \time1 -> \time2 -> +-- > last (x0 : [x | (timex,x) <- ex, time1 <= timex, timex < time2]) -- --- > spill . collect = id -spill :: Event t [a] -> Event t a -spill e = E $ Prim.filterJust $ Prim.mapE (nonempty . concat) (unE e) - where - nonempty [] = Nothing - nonempty xs = Just xs - --- | Construct a time-varying function from an initial value and --- a stream of new values. Think of it as +-- Here is an illustration of the result Behavior at a particular time: -- --- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time]) --- --- Note that the smaller-than-sign in the comparision @timex < time@ means --- that the value of the behavior changes \"slightly after\" --- the event occurrences. This allows for recursive definitions. --- --- Also note that in the case of simultaneous occurrences, --- only the last one is kept. -stepper :: a -> Event t a -> Behavior t a -stepper x e = B $ Prim.stepperB x $ Prim.mapE last $ unE e +-- <> +-- +-- Note: The smaller-than-sign in the comparison @timex < time2@ means +-- that at time @time2 == timex@, the value of the Behavior will +-- still be the previous value. +-- In the illustration, this is indicated by the dots at the end +-- of each step. +-- This allows for recursive definitions. +-- See the discussion below for more on recursion. +stepper :: MonadMoment m => a -> Event a -> m (Behavior a) +stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE --- | The 'accumE' function accumulates a stream of events. +-- | The 'accumE' function accumulates a stream of event values, +-- similar to a /strict/ left scan, 'scanl''. +-- It starts with an initial value and emits a new value +-- whenever an event occurrence happens. +-- The new value is calculated by applying the function in the event +-- to the old value. +-- -- Example: -- -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] --- > = [(time1,"xy"),(time2,"xyz")] --- --- Note that the output events are simultaneous with the input events, --- there is no \"delay\" like in the case of 'accumB'. -accumE :: a -> Event t (a -> a) -> Event t a -accumE acc = E . mapAccumE acc . Prim.mapE concatenate . unE - where - concatenate :: [a -> a] -> a -> ([a],a) - concatenate fs acc = (tail values, last values) - where values = scanl' (flip ($)) acc fs - - mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a - mapAccumE acc = - Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd) +-- > = trimE [(time1,"xy"),(time2,"xyz")] +-- > where +-- > trimE e start = [(time,x) | (time,x) <- e, start <= time] +accumE :: MonadMoment m => a -> Event (a -> a) -> m (Event a) +accumE acc = liftMoment . M . fmap E . Prim.accumE acc . unE --- strict version of scanl -scanl' :: (a -> b -> a) -> a -> [b] -> [a] -scanl' f x ys = x : case ys of - [] -> [] - y:ys -> let z = f x y in z `seq` scanl' f z ys +{-$recursion --- | Apply a time-varying function to a stream of events. --- Think of it as --- --- > apply bf ex = [(time, bf time x) | (time, x) <- ex] --- --- This function is generally used in its infix variant '<@>'. -apply :: Behavior t (a -> b) -> Event t a -> Event t b -apply bf ex = E $ Prim.applyE (Prim.mapB map $ unB bf) (unE ex) +/Recursion/ is a very important technique in FRP that is not apparent +from the type signatures. -{-$classes +Here is a prototypical example. It shows how the 'accumE' can be expressed +in terms of the 'stepper' and 'apply' functions by using recursion: -/Further combinators that Haddock can't document properly./ +> accumE a e1 = mdo +> let e2 = (\a f -> f a) <$> b <@> e1 +> b <- stepper a e2 +> return e2 -> instance Applicative (Behavior t) +(The @mdo@ notation refers to /value recursion/ in a monad. +The 'MonadFix' instance for the 'Moment' class enables this kind of recursive code.) +(Strictly speaking, this also means that 'accumE' is not a primitive, +because it can be expressed in terms of other combinators.) -'Behavior' is an applicative functor. In particular, we have the following functions. +This general pattern appears very often in practice: +A Behavior (here @b@) controls what value is put into an Event (here @e2@), +but at the same time, the Event contributes to changes in this Behavior. +Modeling this situation requires recursion. -> pure :: a -> Behavior t a +For another example, consider a vending machine that sells banana juice. +The amount that the customer still has to pay for a juice +is modeled by a Behavior @bAmount@. +Whenever the customer inserts a coin into the machine, +an Event @eCoin@ occurs, and the amount will be reduced. +Whenver the amount goes below zero, an Event @eSold@ will occur, +indicating the release of a bottle of fresh banana juice, +and the amount to be paid will be reset to the original price. +The model requires recursion, and can be expressed in code as follows: -The constant time-varying value. Think of it as @pure x = \\time -> x@. +> mdo +> let price = 50 :: Int +> bAmount <- accumB price $ unions +> [ subtract 10 <$ eCoin +> , const price <$ eSold ] +> let eSold = whenE ((<= 0) <$> bAmount) eCoin -> (<*>) :: Behavior t (a -> b) -> Behavior t a -> Behavior t b +On one hand, the Behavior @bAmount@ controls whether the Event @eSold@ +occcurs at all; the bottle of banana juice is unavailable to penniless customers. +But at the same time, the Event @eSold@ will cause a reset +of the Behavior @bAmount@, so both depend on each other. -Combine behaviors in applicative style. -Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. +Recursive code like this examples works thanks to the semantics of 'stepper'. +In general, /mutual recursion/ between several 'Event's and 'Behavior's +is always well-defined, +as long as an Event depends on itself only /via/ a Behavior, +and vice versa. -} -{- No monoid instance, sorry. +-- | Obtain the value of the 'Behavior' at a given moment in time. +-- Semantically, it corresponds to +-- +-- > valueB b = \time -> b time +-- +-- Note: The value is immediately available for pattern matching. +-- Unfortunately, this means that @valueB@ is unsuitable for use +-- with value recursion in the 'Moment' monad. +-- If you need recursion, please use 'valueBLater' instead. +valueB :: MonadMoment m => Behavior a -> m a +valueB = liftMoment . M . Prim.valueB . unB -instance Monoid (Event t (a -> a)) where - mempty = never - mappend = unionWith (flip (.)) --} +-- | Obtain the value of the 'Behavior' at a given moment in time. +-- Semantically, it corresponds to +-- +-- > valueBLater b = \time -> b time +-- +-- Note: To allow for more recursion, the value is returned /lazily/ +-- and not available for pattern matching immediately. +-- It can be used safely with most combinators like 'stepper'. +-- If that doesn't work for you, please use 'valueB' instead. +valueBLater :: MonadMoment m => Behavior a -> m a +valueBLater = liftMoment . M . Prim.initialBLater . unB -instance Functor (Event t) where - fmap f e = E $ Prim.mapE (map f) (unE e) -instance Applicative (Behavior t) where - pure x = B $ Prim.pureB x - bf <*> bx = B $ Prim.applyB (unB bf) (unB bx) +-- | Observe a value at those moments in time where +-- event occurrences happen. Semantically, +-- +-- > observeE e = [(time, m time) | (time, m) <- e] +observeE :: Event (Moment a) -> Event a +observeE = E . Prim.observeE . Prim.mapE unM . unE -instance Functor (Behavior t) where - fmap = liftA +-- | Dynamically switch between 'Event'. +-- Semantically, +-- +-- > switchE e0 ee0 time0 = +-- > concat [ trim t1 t2 e | (t1,t2,e) <- intervals ee ] +-- > where +-- > laterThan e time0 = [(timex,x) | (timex,x) <- e, time0 < timex ] +-- > ee = [(time0, e0)] ++ (ee0 `laterThan` time0) +-- > intervals ee = [(time1, time2, e) | ((time1,e),(time2,_)) <- zip ee (tail ee)] +-- > trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2] +switchE :: MonadMoment m => Event a -> Event (Event a) -> m (Event a) +switchE e ee = liftMoment (M (fmap E (Prim.switchE (unE e) (Prim.mapE unE (unE ee))))) +-- | Dynamically switch between 'Behavior'. +-- Semantically, +-- +-- > switchB b0 eb = \time0 -> \time1 -> +-- > last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1 +switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a) +switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE unB . unE + {----------------------------------------------------------------------------- Derived Combinators ------------------------------------------------------------------------------} -{- - -Unfortunately, we can't make a Num instance because that would -require Eq and Show . - -instance Num a => Num (Behavior t a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger --} -infixl 4 <@>, <@ +infixl 4 <@>, <@, @> -- | Infix synonym for the 'apply' combinator. Similar to '<*>'. --- +-- -- > infixl 4 <@> -(<@>) :: Behavior t (a -> b) -> Event t a -> Event t b +(<@>) :: Behavior (a -> b) -> Event a -> Event b (<@>) = apply -- | Tag all event occurrences with a time-varying value. Similar to '<*'. -- -- > infixl 4 <@ -(<@) :: Behavior t b -> Event t a -> Event t b -f <@ g = (const <$> f) <@> g +(<@) :: Behavior b -> Event a -> Event b +f <@ g = (const <$> f) <@> g +-- | Tag all event occurences with a time-varying value. Similar to '*>'. +-- +-- This is the flipped version of '<@', but can be useful when combined with +-- @ApplicativeDo@ to sample from multiple 'Behavior's: +-- +-- @ +-- reactimate $ onEvent @> do +-- x <- behavior1 +-- y <- behavior2 +-- return (print (x + y)) +-- @ +(@>) :: Event a -> Behavior b -> Event b +g @> f = (const <$> f) <@> g + -- | Allow all events that fulfill the time-varying predicate, discard the rest. -- Generalization of 'filterE'. -filterApply :: Behavior t (a -> Bool) -> Event t a -> Event t a +filterApply :: Behavior (a -> Bool) -> Event a -> Event a filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp) -- | Allow events only when the behavior is 'True'. -- Variant of 'filterApply'. -whenE :: Behavior t Bool -> Event t a -> Event t a +whenE :: Behavior Bool -> Event a -> Event a whenE bf = filterApply (const <$> bf) -- | Split event occurrences according to a tag. -- The 'Left' values go into the left component while the 'Right' values -- go into the right component of the result. -split :: Event t (Either a b) -> (Event t a, Event t b) +split :: Event (Either a b) -> (Event a, Event b) split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) where + fromLeft :: Either a b -> Maybe a fromLeft (Left a) = Just a - fromLeft (Right b) = Nothing - fromRight (Left a) = Nothing + fromLeft (Right _) = Nothing + + fromRight :: Either a b -> Maybe b + fromRight (Left _) = Nothing fromRight (Right b) = Just b --- | Combine simultaneous event occurrences into a single occurrence. + +-- | Keep only the next occurence of an event. +-- +-- @once@ also aids the garbage collector by indicating that the result event can be discarded after its only occurrence. -- --- > unionWith f e1 e2 = fmap (foldr1 f) <$> collect (e1 `union` e2) -unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a -unionWith f e1 e2 = E $ Prim.unionWith g (unE e1) (unE e2) - where g xs ys = singleton $ foldr1 f (xs ++ ys) +-- > once e = \time0 -> take 1 [(t, a) | (t, a) <- e, time0 <= t] +once :: MonadMoment m => Event a -> m (Event a) +once e = mdo + e1 <- switchE e (never <$ e1) + return e1 --- | Keep only the last occurrence when simultaneous occurrences happen. -calm :: Event t a -> Event t a -calm = fmap last . collect -- $Accumulation. -- Note: All accumulation functions are strict in the accumulated value! --- +-- -- Note: The order of arguments is @acc -> (x,acc)@ -- which is also the convention used by 'unfoldr' and 'State'. --- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. --- It starts with an initial value and combines it with incoming events. --- For example, think +-- | Merge event streams whose values are functions. +-- In case of simultaneous occurrences, the functions at the beginning +-- of the list are applied /after/ the functions at the end. -- +-- > unions [] = never +-- > unions xs = foldr1 (unionWith (.)) xs +-- +-- Very useful in conjunction with accumulation functions like 'accumB' +-- and 'accumE'. +unions :: [Event (a -> a)] -> Event (a -> a) +unions [] = never +unions xs = foldr1 (unionWith (.)) xs + +-- | The 'accumB' function accumulates event occurrences into a 'Behavior'. +-- +-- The value is accumulated using 'accumE' and converted +-- into a time-varying value using 'stepper'. +-- +-- Example: +-- -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] -- > = stepper "x" [(time1,"xy"),(time2,"xyz")] --- --- Note that the value of the behavior changes \"slightly after\" +-- +-- Note: As with 'stepper', the value of the behavior changes \"slightly after\" -- the events occur. This allows for recursive definitions. -accumB :: a -> Event t (a -> a) -> Behavior t a --- accumB x (Event e) = behavior $ AccumB x e -accumB acc = stepper acc . accumE acc +accumB :: MonadMoment m => a -> Event (a -> a) -> m (Behavior a) +accumB acc e = stepper acc =<< accumE acc e -- | Efficient combination of 'accumE' and 'accumB'. -mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) -mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e)) - where e = accumE (undefined,acc) ((. snd) <$> ef) - +mapAccum :: MonadMoment m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc) +mapAccum acc ef = do + e <- accumE (undefined,acc) (lift <$> ef) + b <- stepper acc (snd <$> e) + return (fst <$> e, b) + where + lift f (_,acc) = acc `seq` f acc diff --git a/src/Reactive/Banana/Experimental/Calm.hs b/src/Reactive/Banana/Experimental/Calm.hs deleted file mode 100644 --- a/src/Reactive/Banana/Experimental/Calm.hs +++ /dev/null @@ -1,130 +0,0 @@ -{----------------------------------------------------------------------------- - Reactive Banana -------------------------------------------------------------------------------} -{-# LANGUAGE Rank2Types, MultiParamTypeClasses, - TypeSynonymInstances, FlexibleInstances #-} - -module Reactive.Banana.Experimental.Calm ( - -- * Synopsis - -- | Experimental module: API change very likely. - -- - -- 'Event' type that disallows simultaneous event occurrences. - -- - -- The combinators behave essentially as their counterparts - -- in "Reactive.Banana.Combinators". - - -- * Main types - Event, Behavior, collect, fromCalm, - interpret, - - -- * Core Combinators - module Control.Applicative, - never, unionWith, filterE, accumE, - apply, stepper, - - -- * Derived Combinators - -- ** Filtering - filterJust, - -- ** Accumulation - -- $Accumulation. - accumB, mapAccum, - -- ** Apply class - (<@>), (<@), - ) where - -import Control.Applicative -import Control.Monad - -import Data.Maybe (listToMaybe) - -import qualified Reactive.Banana.Combinators as Prim -import qualified Reactive.Banana.Combinators - -{----------------------------------------------------------------------------- - Main types -------------------------------------------------------------------------------} -newtype Event t a = E { unE :: Prim.Event t a } - -type Behavior t = Reactive.Banana.Combinators.Behavior t - --- | Convert event with possible simultaneous occurrences --- into an 'Event' with a single occurrence. -collect :: Reactive.Banana.Combinators.Event t a -> Event t [a] -collect = E . Prim.collect - --- | Convert event with single occurrences into --- event with possible simultaneous occurrences -fromCalm :: Event t a -> Reactive.Banana.Combinators.Event t a -fromCalm = unE - -singleton x = [x] - --- | Interpretation function. --- Useful for testing. -interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b] -interpret f xs = - map listToMaybe <$> Prim.interpret (unE . f . E) (map singleton xs) - -{----------------------------------------------------------------------------- - Core Combinators -------------------------------------------------------------------------------} --- | Event that never occurs. --- Think of it as @never = []@. -never :: Event t a -never = E $ Prim.never - --- | Merge two event streams of the same type. --- Combine simultaneous values if necessary. -unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a -unionWith f e1 e2 = E $ Prim.unionWith f (unE e1) (unE e2) - --- | Allow all events that fulfill the predicate, discard the rest. -filterE :: (a -> Bool) -> Event t a -> Event t a -filterE p = E . Prim.filterE p . unE - --- | Construct a time-varying function from an initial value and --- a stream of new values. -stepper :: a -> Event t a -> Behavior t a -stepper x e = Prim.stepper x (unE e) - --- | The 'accumE' function accumulates a stream of events. -accumE :: a -> Event t (a -> a) -> Event t a -accumE acc = E . Prim.accumE acc . unE - --- | Apply a time-varying function to a stream of events. -apply :: Behavior t (a -> b) -> Event t a -> Event t b -apply b = E . Prim.apply b . unE - -instance Functor (Event t) where - fmap f = E . fmap f . unE - -{----------------------------------------------------------------------------- - Derived Combinators -------------------------------------------------------------------------------} --- | Keep only the 'Just' values. --- Variant of 'filterE'. -filterJust :: Event t (Maybe a) -> Event t a -filterJust = E . Prim.filterJust . unE - --- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. --- It starts with an initial value and combines it with incoming events. -accumB :: a -> Event t (a -> a) -> Behavior t a -accumB acc = Prim.accumB acc . unE - --- $Accumulation. --- Note: all accumulation functions are strict in the accumulated value! --- acc -> (x,acc) is the order used by 'unfoldr' and 'State'. - --- | Efficient combination of 'accumE' and 'accumB'. -mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) -mapAccum acc ef = let (e,b) = Prim.mapAccum acc (unE ef) in (E e, b) - --- | Infix synonym for the 'apply' combinator. Similar to '<*>'. -(<@>) :: Behavior t (a -> b) -> Event t a -> Event t b -(<@>) = apply - --- | Tag all event occurrences with a time-varying value. Similar to '<*'. -(<@) :: Behavior t a -> Event t b -> Event t a -f <@ g = (const <$> f) <@> g - - diff --git a/src/Reactive/Banana/Frameworks.hs b/src/Reactive/Banana/Frameworks.hs --- a/src/Reactive/Banana/Frameworks.hs +++ b/src/Reactive/Banana/Frameworks.hs @@ -5,31 +5,36 @@ module Reactive.Banana.Frameworks ( -- * Synopsis - -- | Build event networks using existing event-based frameworks - -- and run them. - + -- | Connect to the outside world by building 'EventNetwork's + -- and running them. + -- * Simple use interpretAsHandler, - -- * Building event networks with input/output + -- * Overview -- $build - compile, Frameworks, + + -- * Building event networks with input/output + -- ** Core functions + compile, MomentIO, module Control.Event.Handler, fromAddHandler, fromChanges, fromPoll, - reactimate, Future, reactimate', initial, changes, imposeChanges, - FrameworksMoment(..), execute, liftIOLater, + reactimate, Future, reactimate', + changes, + -- $changes + imposeChanges, + execute, liftIOLater, -- $liftIO module Control.Monad.IO.Class, - + + -- ** Utility functions + -- | This section collects a few convience functions + -- built from the core functions. + interpretFrameworks, newEvent, mapEventIO, newBehavior, + -- * Running event networks - EventNetwork, actuate, pause, - - -- * Utilities - -- $utilities - newEvent, - - -- * Internal - interpretFrameworks, showNetwork, + EventNetwork, actuate, pause, getSize, + ) where import Control.Event.Handler @@ -37,8 +42,7 @@ import Control.Monad.IO.Class import Data.IORef import Reactive.Banana.Combinators -import qualified Reactive.Banana.Internal.Combinators as Prim -import Reactive.Banana.Internal.Phantom +import qualified Reactive.Banana.Prim.High.Combinators as Prim import Reactive.Banana.Types @@ -58,29 +62,29 @@ * perform /output/ in reaction to events. -In constrast, the functions from "Reactive.Banana.Combinators" allow you +In contrast, the functions from "Reactive.Banana.Combinators" allow you to express the output events in terms of the input events. This expression is called an /event graph/. An /event network/ is an event graph together with inputs and outputs. To build an event network, describe the inputs, outputs and event graph in the -'Moment' monad +'MomentIO' monad and use the 'compile' function to obtain an event network from that. To /activate/ an event network, use the 'actuate' function. -The network will register its input event handlers and start +The network will register its input event handlers and start producing output. A typical setup looks like this: - + > main = do > -- initialize your GUI framework > window <- newWindow > ... > > -- describe the event network -> let networkDescription :: forall t. Frameworks t => Moment t () +> let networkDescription :: MomentIO () > networkDescription = do > -- input: obtain Event from functions that register event handlers > emouse <- fromAddHandler $ registerMouseEvent window @@ -91,12 +95,12 @@ > bdie <- fromPoll $ randomRIO (1,6) > > -- express event graph +> behavior1 <- accumB ... > let -> behavior1 = accumB ... > ... > event15 = union event13 event14 -> -> -- output: animate some event occurences +> +> -- output: animate some event occurrences > reactimate $ fmap print event15 > reactimate $ fmap drawCircle eventCircle > @@ -112,24 +116,24 @@ * Use 'reactimate' to animate /output/ events. +* Use 'compile' to put everything together in an 'EventNetwork's +and use 'actuate' to start handling events. + -} {----------------------------------------------------------------------------- Combinators ------------------------------------------------------------------------------} -singletonsE :: Prim.Event a -> Event t a -singletonsE = E . Prim.mapE (:[]) - {- | Output. Execute the 'IO' action whenever the event occurs. Note: If two events occur very close to each other, -there is no guarantee that the @reactimate@s for one +there is no guarantee that the @reactimate@s for one event will have finished before the ones for the next event start executing. This does /not/ affect the values of events and behaviors, it only means that the @reactimate@ for different events may interleave. -Fortuantely, this is a very rare occurrence, and only happens if +Fortunately, this is a very rare occurrence, and only happens if * you call an event handler from inside 'reactimate', @@ -137,7 +141,7 @@ In these cases, the @reactimate@s follow the control flow of your event-based framework. - + Note: An event network essentially behaves like a single, huge callback function. The 'IO' action are not run in a separate thread. The callback function will throw an exception if one of your 'IO' actions @@ -145,16 +149,16 @@ Your event-based framework will have to handle this situation. -} -reactimate :: Frameworks t => Event t (IO ()) -> Moment t () -reactimate = M . Prim.addReactimate . Prim.mapE (return . sequence_) . unE +reactimate :: Event (IO ()) -> MomentIO () +reactimate = MIO . Prim.addReactimate . Prim.mapE return . unE -- | Output. -- Execute the 'IO' action whenever the event occurs. -- -- This version of 'reactimate' can deal with values obtained -- from the 'changes' function. -reactimate' :: Frameworks t => Event t (Future (IO ())) -> Moment t () -reactimate' = M . Prim.addReactimate . Prim.mapE (unF . fmap sequence_ . sequence) . unE +reactimate' :: Event (Future (IO ())) -> MomentIO () +reactimate' = MIO . Prim.addReactimate . Prim.mapE unF . unE -- | Input, @@ -163,8 +167,8 @@ -- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called. -fromAddHandler :: Frameworks t => AddHandler a -> Moment t (Event t a) -fromAddHandler = M . fmap singletonsE . Prim.fromAddHandler +fromAddHandler ::AddHandler a -> MomentIO (Event a) +fromAddHandler = MIO . fmap E . Prim.fromAddHandler -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time. @@ -174,78 +178,116 @@ -- -- This function is occasionally useful, but -- the recommended way to obtain 'Behaviors' is by using 'fromChanges'. --- +-- -- Ideally, the argument IO action just polls a mutable variable, -- it should not perform expensive computations. -- Neither should its side effects affect the event network significantly. -fromPoll :: Frameworks t => IO a -> Moment t (Behavior t a) -fromPoll = M . fmap B . Prim.fromPoll +fromPoll :: IO a -> MomentIO (Behavior a) +fromPoll = MIO . fmap B . Prim.fromPoll -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes. --- +-- -- This is essentially just an application of the 'stepper' combinator. -fromChanges :: Frameworks t => a -> AddHandler a -> Moment t (Behavior t a) -fromChanges initial changes = stepper initial <$> fromAddHandler changes - --- | Output, --- observe the initial value contained in a 'Behavior'. -initial :: Behavior t a -> Moment t a -initial = M . Prim.initialB . unB +fromChanges :: a -> AddHandler a -> MomentIO (Behavior a) +fromChanges initial changes = do + e <- fromAddHandler changes + stepper initial e -- | Output, --- observe when a 'Behavior' changes. --- --- Strictly speaking, a 'Behavior' denotes a value that --- varies /continuously/ in time, --- so there is no well-defined event which indicates when the behavior changes. --- --- Still, for reasons of efficiency, the library provides a way to observe --- changes when the behavior is a step function, for instance as --- created by 'stepper'. There are no formal guarantees, --- but the idea is that +-- return an 'Event' that is adapted to the changes of a 'Behavior'. -- --- > changes (stepper x e) = return (calm e) +-- Remember that semantically, a 'Behavior' is a function @Behavior a = Time -> a@. +-- This means that a Behavior does not have a notion of \"changes\" associated with it. +-- For instance, the following Behaviors are equal: -- --- Note: The values of the event will not become available --- until event processing is complete. +-- > stepper 0 [] +-- > = stepper 0 [(time1, 0), (time2, 0)] +-- > = stepper 0 $ zip [time1,time2..] (repeat 0) +-- +-- In principle, to perform IO actions with the value of a Behavior, +-- one has to sample it using an 'Event' and the 'apply' function. +-- +-- However, in practice, Behaviors are usually step functions. +-- For reasons of efficiency, the library provides a way +-- to obtain an Event that /mostly/ coincides with the steps of a Behavior, +-- so that sampling is only done at a few select points in time. +-- The idea is that +-- +-- > changes =<< stepper x e = return e +-- +-- Please use 'changes' only in a ways that do /not/ distinguish +-- between the different expressions for the same Behavior above. +-- +-- Note that the value of the event is actually the /new/ value, +-- i.e. that value slightly after this point in time. (See the documentation of 'stepper'). +-- This is more convenient. +-- However, the value will not become available until after event processing is complete; +-- this is indicated by the type 'Future'. -- It can be used only in the context of 'reactimate''. -changes :: Frameworks t => Behavior t a -> Moment t (Event t (Future a)) -changes = return . fmap F . singletonsE . Prim.changesB . unB +changes :: Behavior a -> MomentIO (Event (Future a)) +changes = return . E . Prim.mapE F . Prim.changesB . unB +{- $changes + +Note: If you need a variant of the 'changes' function that does /not/ +have the additional 'Future' type, then the following code snippet +may be useful: + +> plainChanges :: Behavior a -> MomentIO (Event a) +> plainChanges b = do +> (e, handle) <- newEvent +> eb <- changes b +> reactimate' $ (fmap handle) <$> eb +> return e + +However, this approach is not recommended, because the result 'Event' +will occur /slightly/ later than the event returned by 'changes'. +In fact, there is no guarantee whatsoever about what /slightly/ means +in this context. Still, it is useful in some cases. + +-} + -- | Impose a different sampling event on a 'Behavior'. -- --- The 'Behavior' will vary continuously as before, but the event returned +-- The 'Behavior' will have the same values as before, but the event returned -- by the 'changes' function will now happen simultaneously with the -- imposed event. -- -- Note: This function is useful only in very specific circumstances. -imposeChanges :: Frameworks t => Behavior t a -> Event t () -> Behavior t a +imposeChanges :: Behavior a -> Event () -> Behavior a imposeChanges b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e)) --- | Dummy type needed to simulate impredicative polymorphism. -newtype FrameworksMoment a - = FrameworksMoment - { runFrameworksMoment :: forall t. Frameworks t => Moment t a } +{- | Dynamically add input and output to an existing event network. -unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a -unFM = runFrameworksMoment --- | Dynamically add input and output to an existing event network. --- --- Note: You can even do 'IO' actions here, but there is no --- guarantee about the order in which they are executed. -execute - :: Frameworks t - => Event t (FrameworksMoment a) - -> Moment t (Event t a) -execute = M - . fmap singletonsE . Prim.executeE - . Prim.mapE (fmap last . sequence . map (unM . unFM) ) - . unE +Note: You can perform 'IO' actions here, which is useful if you want +to register additional event handlers dynamically. +However, if two arguments to 'execute' occur simultaneously, +then the order in which the 'IO' therein are executed is unspecified. +For instance, in the following code + +> example e = do +> e1 <- execute (liftIO (putStrLn "A") <$ e) +> e2 <- execute (liftIO (putStrLn "B") <$ e) +> return (e1,e2) + +it is unspecified whether @A@ or @B@ are printed first. + +Moreover, if the result 'Event' of this function has been garbage collected, +it may also happen that the actions are not executed at all. +In the example above, if the events `e1` and `e2` are not used any further, +then it can be that neither @A@ nor @B@ will be printed. + +If your main goal is to reliably turn events into 'IO' actions, +use the 'reactimate' and 'reactimate'' functions instead. +-} +execute :: Event (MomentIO a) -> MomentIO (Event a) +execute = MIO . fmap E . Prim.executeE . Prim.mapE unMIO . unE + -- $liftIO --- +-- -- > liftIO :: Frameworks t => IO a -> Moment t a -- -- Lift an 'IO' action into the 'Moment' monad. @@ -253,17 +295,14 @@ -- | Lift an 'IO' action into the 'Moment' monad, -- but defer its execution until compilation time. -- This can be useful for recursive definitions using 'MonadFix'. -liftIOLater :: Frameworks t => IO () -> Moment t () -liftIOLater = M . Prim.liftIOLater +liftIOLater :: IO () -> MomentIO () +liftIOLater = MIO . Prim.liftIOLater -- | Compile the description of an event network -- into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on. --- --- Event networks are described in the 'Moment' monad --- and use the 'Frameworks' class constraint. -compile :: (forall t. Frameworks t => Moment t ()) -> IO EventNetwork -compile m = fmap EN $ Prim.compile $ unM (m :: Moment (FrameworksD, t) ()) +compile :: MomentIO () -> IO EventNetwork +compile = fmap EN . Prim.compile . unMIO {----------------------------------------------------------------------------- Running event networks @@ -293,70 +332,92 @@ pause :: EventNetwork -> IO () pause = Prim.pause . unEN --- | A multiline description of the current 'Latch'es and 'Pulse's in --- the 'EventNetwork'. +-- | PROVISIONAL. +-- Measure of the number of events in the event network. +-- Useful for understanding space usage. +getSize :: EventNetwork -> IO Int +getSize = Prim.getSize . unEN + +{----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +-- | Build an 'Event' together with an 'IO' action that can +-- fire occurrences of this event. Variant of 'newAddHandler'. -- --- Incidentally, evaluation the returned string to normal --- form will also force the 'EventNetwork' to some kind of normal form. --- This may be useful for benchmarking purposes. -showNetwork :: EventNetwork -> IO String -showNetwork = Prim.showNetwork . unEN +-- This function is mainly useful for passing callback functions +-- inside a 'reactimate'. +newEvent :: MomentIO (Event a, Handler a) +newEvent = do + (addHandler, fire) <- liftIO newAddHandler + e <- fromAddHandler addHandler + return (e,fire) +-- | Build a 'Behavior' together with an 'IO' action that can +-- update this behavior with new values. +-- +-- Implementation: +-- +-- > newBehavior a = do +-- > (e, fire) <- newEvent +-- > b <- stepper a e +-- > return (b, fire) +newBehavior :: a -> MomentIO (Behavior a, Handler a) +newBehavior a = do + (e, fire) <- newEvent + b <- stepper a e + return (b, fire) + +-- | Build a new 'Event' that contains the result +-- of an IO computation. +-- The input and result events will /not/ be simultaneous anymore, +-- the latter will occur /later/ than the former. +-- +-- Please use the 'fmap' for 'Event' if your computation is pure. +-- +-- Implementation: +-- +-- > mapEventIO f e1 = do +-- > (e2, handler) <- newEvent +-- > reactimate $ (\a -> f a >>= handler) <$> e1 +-- > return e2 +mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b) +mapEventIO f e1 = do + (e2, handler) <- newEvent + reactimate $ (f >=> handler) <$> e1 + return e2 + {----------------------------------------------------------------------------- Simple use ------------------------------------------------------------------------------} --- | Interpret by using a framework internally. --- Only useful for testing library internals. -interpretFrameworks :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]] +-- | Interpret an event processing function by building an 'EventNetwork' +-- and running it. Useful for testing, but uses 'MomentIO'. +-- See 'interpret' for a plain variant. +interpretFrameworks :: (Event a -> MomentIO (Event b)) -> [Maybe a] -> IO [Maybe b] interpretFrameworks f xs = do - output <- newIORef [] + output <- newIORef Nothing (addHandler, runHandlers) <- newAddHandler network <- compile $ do - e <- fromAddHandler addHandler - reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) + e1 <- fromAddHandler addHandler + e2 <- f e1 + reactimate $ writeIORef output . Just <$> e2 actuate network - bs <- forM xs $ \x -> do - runHandlers x - bs <- readIORef output - writeIORef output [] - return bs - return bs + forM xs $ \x -> do + case x of + Nothing -> return Nothing + Just x -> do + runHandlers x + b <- readIORef output + writeIORef output Nothing + return b -- | Simple way to write a single event handler with -- functional reactive programming. -interpretAsHandler - :: (forall t. Event t a -> Event t b) - -> AddHandler a -> AddHandler b +interpretAsHandler :: (Event a -> Moment (Event b)) -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do network <- compile $ do - e <- fromAddHandler addHandlerA - reactimate $ handlerB <$> f e + e1 <- fromAddHandler addHandlerA + e2 <- liftMoment (f e1) + reactimate $ handlerB <$> e2 actuate network return (pause network) - - -{----------------------------------------------------------------------------- - Utilities -------------------------------------------------------------------------------} -{-$utilities - - This section collects a few convenience functions - for unusual use cases. For instance: - - * The event-based framework you want to hook into is poorly designed - - * You have to write your own event loop and roll a little event framework - --} - --- | Build an 'Event' together with an 'IO' action that can --- fire occurrences of this event. Variant of 'newAddHandler'. --- --- This function is mainly useful for passing callback functions --- inside a 'reactimate'. -newEvent :: Frameworks t => Moment t (Event t a, Handler a) -newEvent = do - (addHandler, fire) <- liftIO $ newAddHandler - e <- fromAddHandler addHandler - return (e,fire) diff --git a/src/Reactive/Banana/Internal/Combinators.hs b/src/Reactive/Banana/Internal/Combinators.hs deleted file mode 100644 --- a/src/Reactive/Banana/Internal/Combinators.hs +++ /dev/null @@ -1,210 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-} -module Reactive.Banana.Internal.Combinators where - -import Control.Concurrent.MVar -import Control.Event.Handler -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader -import Data.Functor -import Data.Functor.Identity -import Data.IORef -import qualified Data.Vault.Lazy as Lazy -import qualified Reactive.Banana.Prim as Prim -import qualified Reactive.Banana.Prim.Cached as Prim -import Reactive.Banana.Prim.Cached hiding (runCached) - -type Build = Prim.Build -type Latch = Prim.Latch -type Pulse = Prim.Pulse -type Future = Prim.Future - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} -type Behavior a = Cached Moment' (Latch a, Pulse ()) -type Event a = Cached Moment' (Pulse a) - -type MomentT m = ReaderT EventNetwork (Prim.BuildT m) -type Moment = MomentT IO -type Moment' = MomentT Identity - -instance (Monad m, MonadFix m, HasCache m) - => HasCache (ReaderT EventNetwork m) where - retrieve key = lift $ retrieve key - write key a = lift $ write key a - -liftBuild :: Monad m => Build a -> MomentT m a -liftBuild = lift . Prim.liftBuild - -runCached :: Monad m => Cached Moment' a -> MomentT m a -runCached = mapReaderT Prim.liftBuild . Prim.runCached - -{----------------------------------------------------------------------------- - Interpretation -------------------------------------------------------------------------------} -interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] -interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined - where - g pulse = runCached =<< f (Prim.fromPure pulse) - -- Ignore any addHandler inside the Moment - -{----------------------------------------------------------------------------- - IO -------------------------------------------------------------------------------} --- | Data type representing an event network. -data EventNetwork = EventNetwork - { runStep :: Prim.Step -> IO () - , actuate :: IO () - , pause :: IO () - , showNetwork :: IO String - } - --- | Compile to an event network. -compile :: Moment () -> IO EventNetwork -compile setup = do - actuated <- newIORef False -- flag to set running status - s <- newEmptyMVar -- setup callback machinery - let - whenFlag flag action = readIORef flag >>= \b -> when b action - runStep f = whenFlag actuated $ do - s1 <- takeMVar s -- read and take lock - -- pollValues <- sequence polls -- poll mutable data - (output, s2) <- f s1 -- calculate new state - putMVar s s2 -- write state - output -- run IO actions afterwards - - eventNetwork = EventNetwork - { runStep = runStep - , actuate = writeIORef actuated True - , pause = writeIORef actuated False - , showNetwork = show <$> readMVar s - } - - (output, s0) <- -- compile initial graph - Prim.compile (runReaderT setup eventNetwork) Prim.emptyNetwork - putMVar s s0 -- set initial state - - return $ eventNetwork - -fromAddHandler :: AddHandler a -> Moment (Event a) -fromAddHandler addHandler = do - key <- liftIO $ Lazy.newKey - (p, fire) <- liftBuild $ Prim.newInput key - network <- ask - liftIO $ register addHandler $ runStep network . fire - return $ Prim.fromPure p - -addReactimate :: Event (Future (IO ())) -> Moment () -addReactimate e = do - p <- runCached e - liftBuild $ Prim.addHandler p id - -fromPoll :: IO a -> Moment (Behavior a) -fromPoll poll = do - a <- liftIO poll - e <- liftBuild $ do - p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP - return $ Prim.fromPure p - return $ stepperB a e - -liftIONow :: IO a -> Moment a -liftIONow = liftIO - -liftIOLater :: IO () -> Moment () -liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater - -imposeChanges :: Behavior a -> Event () -> Behavior a -imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2) - -{----------------------------------------------------------------------------- - Combinators - basic -------------------------------------------------------------------------------} -never = don'tCache $ liftBuild $ Prim.neverP -unionWith f = liftCached2 $ (liftBuild .) . Prim.unionWithP f -filterJust = liftCached1 $ liftBuild . Prim.filterJustP -accumE x = liftCached1 $ liftBuild . fmap snd . Prim.accumL x -mapE f = liftCached1 $ liftBuild . Prim.mapP f -applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px - -changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px - --- FIXME: To allow more recursion, create the latch first and --- build the pulse later. -stepperB a = \c1 -> cache $ do - p0 <- runCached c1 - liftBuild $ do - p1 <- Prim.mapP const p0 - p2 <- Prim.mapP (const ()) p1 - (l,_) <- Prim.accumL a p1 - return (l,p2) - -pureB a = stepperB a never -applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do - p3 <- Prim.unionWithP const p1 p2 - let l3 = Prim.applyL l1 l2 - return (l3,p3) -mapB f = applyB (pureB f) - -{----------------------------------------------------------------------------- - Combinators - dynamic event switching -------------------------------------------------------------------------------} -initialB :: Behavior a -> Moment a -initialB b = do - ~(l,_) <- runCached b - liftBuild $ Prim.readLatch l - -trimE :: Event a -> Moment (Moment (Event a)) -trimE e = do - p <- runCached e -- add pulse to network - -- NOTE: if the pulse is not connected to an input node, - -- it will be garbage collected right away. - -- TODO: Do we need to check for this? - return $ return $ fromPure p -- remember it henceforth - -trimB :: Behavior a -> Moment (Moment (Behavior a)) -trimB b = do - ~(l,p) <- runCached b -- add behavior to network - return $ return $ fromPure (l,p) -- remember it henceforth - -executeP :: Monad m => Pulse (Moment a) -> MomentT m (Pulse a) -executeP p1 = do - p2 <- liftBuild $ Prim.mapP runReaderT p1 - r <- ask - liftBuild $ Prim.executeP p2 r - -observeE :: Event (Moment a) -> Event a -observeE = liftCached1 $ executeP - -executeE :: Event (Moment a) -> Moment (Event a) -executeE e = do - p <- runCached e - result <- executeP p - return $ fromPure result - -switchE :: Event (Moment (Event a)) -> Event a -switchE = liftCached1 $ \p1 -> do - p2 <- liftBuild $ Prim.mapP (runCached =<<) p1 - p3 <- executeP p2 - liftBuild $ Prim.switchP p3 - -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a -switchB = liftCached2 $ \(l0,p0) p1 -> do - p2 <- liftBuild $ Prim.mapP (runCached =<<) p1 - p3 <- executeP p2 - - liftBuild $ do - lr <- Prim.switchL l0 =<< Prim.mapP fst p3 - -- TODO: switch away the initial behavior - let c1 = p0 -- initial behavior changes - c2 <- Prim.mapP (const ()) p3 -- or switch happens - c3 <- Prim.switchP =<< Prim.mapP snd p3 -- or current behavior changes - pr <- merge c1 =<< merge c2 c3 - return (lr, pr) - -merge = Prim.unionWithP (\_ _ -> ()) diff --git a/src/Reactive/Banana/Internal/Phantom.hs b/src/Reactive/Banana/Internal/Phantom.hs deleted file mode 100644 --- a/src/Reactive/Banana/Internal/Phantom.hs +++ /dev/null @@ -1,21 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-} -module Reactive.Banana.Internal.Phantom ( - -- * Synopsis - -- | Classes used to constrain the phantom type @t@ in the 'Moment' type. - - -- * Documentation - Frameworks, FrameworksD, - ) where - --- | Class constraint on the type parameter @t@ of the 'Moment' monad. --- --- Indicates that we can add input and output to an event network. -class Frameworks t - --- | Data type for discharging the 'Frameworks' constraint. -data FrameworksD - -instance Frameworks (FrameworksD,t) diff --git a/src/Reactive/Banana/Model.hs b/src/Reactive/Banana/Model.hs --- a/src/Reactive/Banana/Model.hs +++ b/src/Reactive/Banana/Model.hs @@ -1,152 +1,184 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecursiveDo #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Reactive.Banana.Model ( -- * Synopsis - -- | Model implementation of the abstract syntax tree. - - -- * Description - -- $model + -- | Model implementation for learning and testing. - -- * Combinators - -- ** Data types - Event, Behavior, - -- ** Basic - never, filterJust, unionWith, mapE, accumE, applyE, - stepperB, pureB, applyB, mapB, - -- ** Dynamic event switching - Moment, - initialB, trimE, trimB, observeE, switchE, switchB, - - -- * Interpretation + -- * Overview + -- $overview + + -- * Core Combinators + -- ** Event and Behavior + Nat, Time, + Event(..), Behavior(..), interpret, + -- ** First-order + module Control.Applicative, + never, unionWith, mergeWith, filterJust, apply, + -- ** Moment and accumulation + Moment(..), accumE, stepper, + -- ** Higher-order + valueB, observeE, switchE, switchB, ) where import Control.Applicative -import Control.Monad (join) +import Control.Monad +import Control.Monad.Fix +import Data.These (These(..), these) +import Data.Maybe (fromMaybe) -{-$model +{-$overview -This module contains the model implementation for the primitive combinators -defined "Reactive.Banana.Internal.AST" -which in turn are the basis for the official combinators -documented in "Reactive.Banana.Combinators". +This module reimplements the key FRP types and functions from the module +"Reactive.Banana.Combinators" in a way that is hopefully easier to understand. +Thereby, this model also specifies the semantics of the library. +Of course, the real implementation is much more efficient than this model here. -Look at the source code to make maximal use of this module. +To understand the model in detail, look at the source code! (If there is no link to the source code at every type signature, then you have to run cabal with --hyperlink-source flag.) -This model is /authoritative/: when observed with the 'interpretModel' function, -both the actual implementation and its model /must/ agree on the result. -Note that this must also hold for recursive and partial definitions +This model is /authoritative/: +Event functions that have been constructed using the same combinators +/must/ give the same results when run with the @interpret@ function +from either the module "Reactive.Banana.Combinators" +or the module "Reactive.Banana.Model". +This must also hold for recursive and partial definitions (at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). -Concerning time and space complexity, the model is not authoritative, however. -Implementations are free to be much more efficient. -} {----------------------------------------------------------------------------- - Basic Combinators + Event and Behavior ------------------------------------------------------------------------------} -type Event a = [Maybe a] -- should be abstract -data Behavior a = StepperB !a (Event a) -- should be abstract +-- | Natural numbers (poorly represented). +type Nat = Int -interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] -interpret f e = f e 0 +-- | The FRP model used in this library is actually a model with continuous time. +-- +-- However, it can be shown that this model is observationally +-- equivalent to a particular model with (seemingly) discrete time steps, +-- which is implemented here. +-- The main reason for doing this is to be able to handle recursion correctly. +-- Details will be explained elsewhere. +type Time = Nat -- begins at t = 0 -never :: Event a -never = repeat Nothing +-- | Event is modeled by an /infinite/ list of 'Maybe' values. +-- It is isomorphic to @Time -> Maybe a@. +-- +-- 'Nothing' indicates that no occurrence happens, +-- while 'Just' indicates that an occurrence happens. +newtype Event a = E { unE :: [Maybe a] } deriving (Show) -filterJust :: Event (Maybe a) -> Event a -filterJust = map join +-- | Behavior is modeled by an /infinite/ list of values. +-- It is isomorphic to @Time -> a@. +newtype Behavior a = B { unB :: [a] } deriving (Show) -unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a -unionWith f = zipWith g - where - g (Just x) (Just y) = Just $ f x y - g (Just x) Nothing = Just x - g Nothing (Just y) = Just y - g Nothing Nothing = Nothing +interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] +interpret f as = + take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing) -mapE f = applyE (pureB f) +{----------------------------------------------------------------------------- + First-order +------------------------------------------------------------------------------} +instance Functor Event where + fmap f (E xs) = E (fmap (fmap f) xs) -applyE :: Behavior (a -> b) -> Event a -> Event b -applyE _ [] = [] -applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs - where - step a (Nothing:b) = stepperB a b - step _ (Just a :b) = stepperB a b +instance Functor Behavior where + fmap f (B xs) = B (fmap f xs) -accumE :: a -> Event (a -> a) -> Event a -accumE x [] = [] -accumE x (Nothing:fs) = Nothing : accumE x fs -accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) +instance Applicative Behavior where + pure x = B $ repeat x + (B f) <*> (B x) = B $ zipWith ($) f x -stepperB :: a -> Event a -> Behavior a -stepperB = StepperB +never :: Event a +never = E $ repeat Nothing --- applicative functor -pureB x = stepperB x never +unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a +unionWith = mergeWith id id -applyB :: Behavior (a -> b) -> Behavior a -> Behavior b -applyB (StepperB f fe) (StepperB x xe) = - stepperB (f x) $ mapE (uncurry ($)) pair +mergeWith + :: (a -> c) + -> (b -> c) + -> (a -> b -> c) + -> Event a + -> Event b + -> Event c +mergeWith f g h xs ys = these f g h <$> merge xs ys + +merge :: Event a -> Event b -> Event (These a b) +merge (E xs) (E ys) = E $ zipWith combine xs ys where - pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe) - changeL f (_,x) = (f,x) - changeR x (f,_) = (f,x) + combine Nothing Nothing = Nothing + combine (Just x) Nothing = Just (This x) + combine Nothing (Just y) = Just (That y) + combine (Just x) (Just y) = Just (These x y) -mapB f = applyB (pureB f) +filterJust :: Event (Maybe a) -> Event a +filterJust = E . fmap join . unE +apply :: Behavior (a -> b) -> Event a -> Event b +apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE + {----------------------------------------------------------------------------- - Dynamic Event Switching + Moment and accumulation ------------------------------------------------------------------------------} -type Time = Int -type Moment a = Time -> a -- should be abstract +newtype Moment a = M { unM :: Time -> a } -{- +instance Functor Moment where fmap f = M . fmap f . unM +instance Applicative Moment where + pure = M . const + (<*>) = ap instance Monad Moment where - return = const - m >>= g = \time -> g (m time) time --} + return = pure + (M m) >>= k = M $ \time -> unM (k $ m time) time -initialB :: Behavior a -> Moment a -initialB (StepperB x _) = return x +instance MonadFix Moment where + mfix f = M $ mfix (unM . f) -trimE :: Event a -> Moment (Moment (Event a)) -trimE e = \now -> \later -> drop (later - now) e +-- Forget all event occurences before a particular time +forgetE :: Time -> Event a -> [Maybe a] +forgetE time (E xs) = drop time xs -trimB :: Behavior a -> Moment (Moment (Behavior a)) -trimB b = \now -> \later -> bTrimmed !! (later - now) +stepper :: a -> Event a -> Moment (Behavior a) +stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e) where - bTrimmed = iterate drop1 b + step i ~(x:xs) = i : step next xs + where next = fromMaybe i x - drop1 (StepperB x [] ) = StepperB x never - drop1 (StepperB x (Just y :ys)) = StepperB y ys - drop1 (StepperB x (Nothing:ys)) = StepperB x ys +-- Expressed using recursion and the other primitives +-- FIXME: Strictness! +accumE :: a -> Event (a -> a) -> Moment (Event a) +accumE a e1 = mdo + let e2 = ((\a f -> f a) <$> b) `apply` e1 + b <- stepper a e2 + return e2 +{----------------------------------------------------------------------------- + Higher-order +------------------------------------------------------------------------------} +valueB :: Behavior a -> Moment a +valueB (B b) = M $ \time -> b !! time + observeE :: Event (Moment a) -> Event a -observeE = zipWith (\time -> fmap ($ time)) [0..] +observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE -switchE :: Event (Moment (Event a)) -> Event a -switchE = step never . observeE +switchE :: Event a -> Event (Event a) -> Moment (Event a) +switchE e es = M $ \t -> E $ + replicate t Nothing ++ switch (unE e) (forgetE t (forgetDiagonalE es)) where - step ys [] = ys - step (y:ys) (Nothing:xs) = y : step ys xs - step (y:ys) (Just zs:xs) = y : step (drop 1 zs) xs - -- assume that the dynamic events are at least as long as the - -- switching event + switch (x:xs) (Nothing : ys) = x : switch xs ys + switch (x: _) (Just xs : ys) = x : switch (tail xs) ys -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a -switchB (StepperB x e) = stepperB x . step e . observeE - where - step ys [] = ys - step (y:ys) (Nothing :xs) = y : step ys xs - step (y:ys) (Just (StepperB x zs):xs) = Just value : step (drop 1 zs) xs - where - value = case zs of - Just z : _ -> z -- new behavior changes right away - _ -> x -- new behavior stays constant for a while +forgetDiagonalE :: Event (Event a) -> Event [Maybe a] +forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE +switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a) +switchB b e = diagonalB <$> stepper b e +diagonalB :: Behavior (Behavior a) -> Behavior a +diagonalB = B . zipWith (\time xs -> xs !! time) [0..] . map unB . unB diff --git a/src/Reactive/Banana/Prim.hs b/src/Reactive/Banana/Prim.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim.hs +++ /dev/null @@ -1,42 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Reactive.Banana.Prim ( - -- * Synopsis - -- | This is an internal module, useful if you want to - -- implemented your own FRP library. - -- If you just want to use FRP in your project, - -- have a look at "Reactive.Banana" instead. - - -- * Evaluation - Step, Network, emptyNetwork, - - -- * Build FRP networks - Build, liftIOLater, BuildIO, BuildT, liftBuild, compile, - module Control.Monad.IO.Class, - - -- * Testing - interpret, mapAccumM, mapAccumM_, runSpaceProfile, - - -- * IO - newInput, addHandler, readLatch, - - -- * Pulse - Pulse, - neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, unionWithP, - - -- * Latch - Latch, - pureL, mapL, applyL, accumL, applyP, - - -- * Dynamic event switching - switchL, executeP, switchP - ) where - - -import Control.Monad.IO.Class -import Reactive.Banana.Prim.Combinators -import Reactive.Banana.Prim.Compile -import Reactive.Banana.Prim.IO -import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, liftIOLater) -import Reactive.Banana.Prim.Types diff --git a/src/Reactive/Banana/Prim/Cached.hs b/src/Reactive/Banana/Prim/Cached.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Cached.hs +++ /dev/null @@ -1,72 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo #-} -module Reactive.Banana.Prim.Cached ( - -- | Utility for executing monadic actions once - -- and then retrieving values from a cache. - -- - -- Very useful for observable sharing. - HasCache(..), - Cached, runCached, cache, fromPure, don'tCache, - liftCached1, liftCached2, - ) where - -import Control.Monad -import Control.Monad.Fix -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy (Key, newKey) -import System.IO.Unsafe (unsafePerformIO) - -{----------------------------------------------------------------------------- - Cache type -------------------------------------------------------------------------------} -data Cached m a = Cached (m a) - -runCached :: Cached m a -> m a -runCached (Cached x) = x - --- | Type class for monads that have a lazy 'Vault' that can be used as a cache. --- --- The cache has to be lazy in the values in order to be useful for recursion. -class (Monad m, MonadFix m) => HasCache m where - retrieve :: Lazy.Key a -> m (Maybe a) - write :: Lazy.Key a -> a -> m () - --- | An action whose result will be cached. --- Executing the action the first time in the monad will --- execute the side effects. From then on, --- only the generated value will be returned. -{-# NOINLINE cache #-} -cache :: HasCache m => m a -> Cached m a -cache m = unsafePerformIO $ do - key <- Lazy.newKey - return $ Cached $ do - ma <- retrieve key -- look up calculation result - case ma of - Nothing -> mdo - write key a -- black-hole result first - a <- m -- evaluate - return a - Just a -> return a -- return cached result - --- | Return a pure value. Doesn't make use of the cache. -fromPure :: HasCache m => a -> Cached m a -fromPure = Cached . return - --- | Lift an action that is /not/ chached, for instance because it is idempotent. -don'tCache :: HasCache m => m a -> Cached m a -don'tCache = Cached - -liftCached1 :: HasCache m => (a -> m b) -> Cached m a -> Cached m b -liftCached1 f ca = cache $ do - a <- runCached ca - f a - -liftCached2 :: HasCache m => - (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c -liftCached2 f ca cb = cache $ do - a <- runCached ca - b <- runCached cb - f a b - diff --git a/src/Reactive/Banana/Prim/Combinators.hs b/src/Reactive/Banana/Prim/Combinators.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Combinators.hs +++ /dev/null @@ -1,191 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo #-} -module Reactive.Banana.Prim.Combinators where - -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class - -import Reactive.Banana.Prim.Dated (Box(..)) -import Reactive.Banana.Prim.Plumbing - ( neverP, newPulse, newLatch, cachedLatch - , dependOn, changeParent - , readPulseP, readLatchP, readLatchFutureP, liftBuildP, liftBuildIOP - ) -import Reactive.Banana.Prim.Types (Latch(..), Future, Pulse, Build, BuildIO) - -import Debug.Trace --- debug s = trace s -debug s = id - -{----------------------------------------------------------------------------- - Combinators - basic -------------------------------------------------------------------------------} -mapP :: (a -> b) -> Pulse a -> Build (Pulse b) -mapP f p1 = do - p2 <- newPulse "mapP" $ {-# SCC mapP #-} fmap f <$> readPulseP p1 - p2 `dependOn` p1 - return p2 - --- | Tag a 'Pulse' with future values of a 'Latch'. --- --- This is in contrast to 'applyP' which applies the current value --- of a 'Latch' to a pulse. -tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a)) -tagFuture x p1 = do - p2 <- newPulse "tagFuture" $ - fmap . const <$> readLatchFutureP x <*> readPulseP p1 - p2 `dependOn` p1 - return p2 - -filterJustP :: Pulse (Maybe a) -> Build (Pulse a) -filterJustP p1 = do - p2 <- newPulse "filterJustP" $ {-# SCC filterJustP #-} join <$> readPulseP p1 - p2 `dependOn` p1 - return p2 - -unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b) -unsafeMapIOP f p1 = do - p2 <- newPulse "unsafeMapIOP" $ - {-# SCC unsafeMapIOP #-} eval =<< readPulseP p1 - p2 `dependOn` p1 - return p2 - where - eval (Just x) = Just <$> liftIO (f x) - eval Nothing = return Nothing - -unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a) -unionWithP f px py = do - p <- newPulse "unionWithP" $ - {-# SCC unionWithP #-} eval <$> readPulseP px <*> readPulseP py - p `dependOn` px - p `dependOn` py - return p - where - eval (Just x) (Just y) = Just (f x y) - eval (Just x) Nothing = Just x - eval Nothing (Just y) = Just y - eval Nothing Nothing = Nothing - --- See note [LatchRecursion] -applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) -applyP f x = do - p <- newPulse "applyP" $ - {-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x - p `dependOn` x - return p - -pureL :: a -> Latch a -pureL a = Latch { getValueL = return (pure a) } - --- specialization of mapL f = applyL (pureL f) -mapL :: (a -> b) -> Latch a -> Latch b -mapL f lx = cachedLatch $ {-# SCC mapL #-} fmap f <$> getValueL lx - -applyL :: Latch (a -> b) -> Latch a -> Latch b -applyL lf lx = cachedLatch $ - {-# SCC applyL #-} (<*>) <$> getValueL lf <*> getValueL lx - -accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) -accumL a p1 = do - (updateOn, x) <- newLatch a - p2 <- applyP (mapL (\x f -> f x) x) p1 - updateOn p2 - return (x,p2) - --- specialization of accumL -stepperL :: a -> Pulse a -> Build (Latch a) -stepperL a p = do - (updateOn, x) <- newLatch a - updateOn p - return x - -{----------------------------------------------------------------------------- - Combinators - dynamic event switching -------------------------------------------------------------------------------} -switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a) -switchL l pl = mdo - x <- stepperL l pl - return $ Latch { getValueL = getValueL x >>= \(Box a) -> getValueL a } - -executeP :: Pulse (b -> BuildIO a) -> b -> Build (Pulse a) -executeP p1 b = do - p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1 - p2 `dependOn` p1 - return p2 - where - eval (Just x) = Just <$> liftBuildIOP (x b) - eval Nothing = return Nothing - -switchP :: Pulse (Pulse a) -> Build (Pulse a) -switchP pp = mdo - never <- neverP - lp <- stepperL never pp - let - -- switch to a new parent - switch = do - mnew <- readPulseP pp - case mnew of - Nothing -> return () - Just new -> liftBuildP $ p2 `changeParent` new - return Nothing - -- fetch value from old parent - eval = readPulseP =<< readLatchP lp - - p1 <- newPulse "switchP_in" switch :: Build (Pulse ()) - p1 `dependOn` pp - p2 <- newPulse "switchP_out" eval - return p2 - -{----------------------------------------------------------------------------- - Notes -------------------------------------------------------------------------------} -{- - -* Note [PulseCreation] - -We assume that we do not have to calculate a pulse occurrence -at the moment we create the pulse. Otherwise, we would have -to recalculate the dependencies *while* doing evaluation; -this is a recipe for desaster. - -* Note [unsafePerformIO] - -We're using @unsafePerformIO@ only to get @Key@ and @Unique@. -It's not great, but it works. - -Unfortunately, using @IO@ as the base of the @Network@ monad -transformer doens't work because it doesn't support recursion -and @mfix@ very well. - -We could use the @ST@ monad, but this would add a type parameter -to everything. A refactoring of this scope is too annoying for -my taste right now. - -* Note [LatchRecursion] - -... - -* Note [LatchStrictness] - -Any value that is stored in the graph over a longer -period of time must be stored in WHNF. - -This implies that the values in a latch must be forced to WHNF -when storing them. That doesn't have to be immediately -since we are tying a knot, but it definitely has to be done -before evaluateGraph is done. - -It also implies that reading a value from a latch must -be forced to WHNF before storing it again, so that we don't -carry around the old collection of latch values. -This is particularly relevant for `applyL`. - -Conversely, since latches are the only way to store values over time, -this is enough to guarantee that there are no space leaks in this regard. - --} - - diff --git a/src/Reactive/Banana/Prim/Compile.hs b/src/Reactive/Banana/Prim/Compile.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Compile.hs +++ /dev/null @@ -1,83 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Reactive.Banana.Prim.Compile where - -import Data.Functor -import Data.IORef -import qualified Data.Vault.Lazy as Lazy -import Reactive.Banana.Prim.Combinators -import Reactive.Banana.Prim.IO -import Reactive.Banana.Prim.Plumbing -import Reactive.Banana.Prim.Types - -{----------------------------------------------------------------------------- - Compilation -------------------------------------------------------------------------------} --- | Change a 'Network' of pulses and latches by --- executing a 'BuildIO' action. -compile :: BuildIO a -> Network -> IO (a, Network) -compile = flip runBuildIO - -{----------------------------------------------------------------------------- - Testing -------------------------------------------------------------------------------} --- | Simple interpreter for pulse/latch networks. --- --- Mainly useful for testing functionality --- --- Note: The result is not computed lazily, for similar reasons --- that the 'sequence' function does not compute its result lazily. -interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b] -interpret f xs = do - key <- Lazy.newKey - o <- newIORef Nothing - let network = do - (pin, sin) <- liftBuild $ newInput key - pmid <- f pin - pout <- liftBuild $ mapP return pmid - liftBuild $ addHandler pout (writeIORef o . Just) - return sin - - -- compile initial network - (sin, state) <- compile network emptyNetwork - - let go Nothing s1 = return (Nothing,s1) - go (Just a) s1 = do - (reactimate,s2) <- sin a s1 - reactimate -- write output - ma <- readIORef o -- read output - writeIORef o Nothing - return (ma,s2) - - mapAccumM go state xs -- run several steps - --- | Execute an FRP network with a sequence of inputs, but discard results. --- --- Mainly useful for testing whether there are space leaks. -runSpaceProfile :: (Pulse a -> BuildIO void) -> [a] -> IO () -runSpaceProfile f xs = do - key <- Lazy.newKey - let g = do - (p1, fire) <- liftBuild $ newInput key - f p1 - return fire - (fire,network) <- compile g emptyNetwork - - mapAccumM_ fire network xs - --- | 'mapAccum' for a monad. -mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b] -mapAccumM _ _ [] = return [] -mapAccumM f s0 (x:xs) = do - (b,s1) <- f x s0 - bs <- mapAccumM f s1 xs - return (b:bs) - --- | Strict 'mapAccum' for a monad. Discards results. -mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m () -mapAccumM_ _ _ [] = return () -mapAccumM_ f s0 (x:xs) = do - (_,s1) <- f x s0 - mapAccumM_ f s1 xs - diff --git a/src/Reactive/Banana/Prim/Dated.hs b/src/Reactive/Banana/Prim/Dated.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Dated.hs +++ /dev/null @@ -1,106 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Reactive.Banana.Prim.Dated ( - -- | A cache with timestamps. - - -- * Time - Time, ancient, beginning, next, - -- * Cache - Vault, Key, empty, newKey, findWithDefault, - -- * Strictness - Box(..), - -- * Computations - Dated, runDated, update', cache, - - ) where - -import Control.Applicative hiding (empty) -import Control.Monad.Trans.RWS -import Data.Functor -import Data.Monoid -import qualified Data.Vault.Strict as Strict -import Prelude hiding (lookup) - -{----------------------------------------------------------------------------- - Time monoid -------------------------------------------------------------------------------} -newtype Time = T Integer deriving (Eq, Ord, Show, Read) - -ancient :: Time -ancient = T 0 - -beginning :: Time -beginning = T 1 - -next :: Time -> Time -next (T n) = T (n+1) - -instance Monoid Time where - mappend (T x) (T y) = T (max x y) - mempty = ancient - -{----------------------------------------------------------------------------- - Strictness -------------------------------------------------------------------------------} --- | A strict box of potentially lazy value. -data Box a = Box { unBox :: a } - -instance Functor Box where - fmap f (Box x) = Box (f x) - -instance Applicative Box where - pure x = Box x - (Box f) <*> (Box x) = Box (f x) - -{----------------------------------------------------------------------------- - Cache data type -------------------------------------------------------------------------------} -newKey :: IO (Key a) -newKey = Strict.newKey - -empty :: Vault -empty = Strict.empty - -type Vault = Strict.Vault -type Key a = Strict.Key (Timed a) - -{----------------------------------------------------------------------------- - Cached computations -------------------------------------------------------------------------------} -type Dated = RWS () Time Vault -data Timed a = Timed !(Box a) !Time - -runDated :: Dated a -> Vault -> (a, Vault) -runDated m s1 = let (a,s2,_) = runRWS m () s1 in (a,s2) - -findWithDefault :: a -> Key a -> Dated (Box a) -findWithDefault a key = do - ma <- Strict.lookup key <$> get - case ma of - Nothing -> return (Box a) - Just (Timed a t) -> tell t >> return a - --- | Update a value inside the cache. --- The value will be evaluated to WHNF when the cache is evaluated to WHNF. -update' :: Key a -> Time -> a -> Vault -> Vault -update' key t a = Strict.insert key (Timed (a `seq` Box a) t) - -cache :: Key a -> Dated (Box a) -> Dated (Box a) --- cache key m = m --- Observation: If a is a function type, then forcing --- it will not necessarily remove all the function application things. -cache key m = do - (aNew, timeNew) <- listen m - let refresh = do - modify $ Strict.insert key (Timed aNew timeNew) - return aNew - - ma <- Strict.lookup key <$> get - case ma of - Just (Timed aOld timeOld) - | timeOld >= timeNew -> do -- cache is more recent - tell timeOld - return aOld - | otherwise -> refresh -- cache is too old - Nothing -> refresh diff --git a/src/Reactive/Banana/Prim/Dependencies.hs b/src/Reactive/Banana/Prim/Dependencies.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Dependencies.hs +++ /dev/null @@ -1,172 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -module Reactive.Banana.Prim.Dependencies ( - -- | Utilities for operating with dependency graphs. - Deps, dOrder, empty, allChildren, children, parents, - addChild, changeParent, - - Continue(..), maybeContinue, traverseDependencies, - - DepsQueue, emptyQ, insert, minView, - ) where - -import Control.Monad.Trans.Writer -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Hashable -import qualified Data.IntPSQ as Q - -import Reactive.Banana.Prim.Order -import qualified Reactive.Banana.Prim.Order as Order - -type Map = Map.HashMap -type Set = Set.HashSet - -{----------------------------------------------------------------------------- - Dependency graph -------------------------------------------------------------------------------} --- | A dependency graph. -data Deps a = Deps - { dChildren :: Map a [a] -- children depend on their parents - , dParents :: Map a [a] - , dOrder :: Order a - } deriving (Show) - --- | Representation of the depencencies as an association list of nodes --- to children. -allChildren :: Deps a -> [(a, [a])] -allChildren = Map.toList . dChildren - --- | Children of a node. -children deps x = - {-# SCC children #-} maybe [] id . Map.lookup x $ dChildren deps - --- | Parents of a node. -parents deps x = maybe [] id . Map.lookup x $ dParents deps - --- | The empty dependency graph. -empty :: Hashable a => Deps a -empty = Deps - { dChildren = Map.empty - , dParents = Map.empty - , dOrder = Order.flat - } - --- | Add a new dependency. -addChild :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a -addChild parent child deps1@(Deps{..}) = deps2 - where - deps2 = Deps - { dChildren = Map.insertWith (++) parent [child] dChildren - , dParents = Map.insertWith (++) child [parent] dParents - , dOrder = ensureAbove child parent dOrder - } - when b f = if b then f else id - --- | Change the parent of the first argument to be the second one. -changeParent :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a -changeParent child parent deps1@(Deps{..}) = deps2 - where - deps2 = Deps - { dChildren = Map.insertWith (++) parent [child] - $ removeChild parentsOld dChildren - , dParents = Map.insert child [parent] dParents - , dOrder = recalculateParent child parent (parents deps2) dOrder - } - parentsOld = parents deps1 child - removeChild1 = Map.adjust (filter (/= child)) - removeChild = concatenate . map removeChild1 - concatenate = foldr (.) id - -{----------------------------------------------------------------------------- - Traversal -------------------------------------------------------------------------------} --- | Data type for signaling whether to continue a traversal or not. -data Continue = Children | Done - deriving (Eq, Ord, Show, Read) - --- | Convert a 'Maybe' value into a 'Continue' decision. -maybeContinue :: Maybe a -> Continue -maybeContinue Nothing = Done -maybeContinue (Just _) = Children - --- | Starting with a set of root nodes, peform a monadic action --- for each node. If the action returns 'Children', its children will also --- be traversed at some point. --- However, all nodes are traversed in dependency order: --- A child node is only traversed when all its parent nodes have been traversed. -traverseDependencies :: forall a m. (Eq a, Hashable a, Monad m) - => (a -> m Continue) -> Deps a -> [a] -> m () -traverseDependencies f deps roots = go $ insertList roots emptyQ - where - order = dOrder deps - insertList xs q = foldr (\x -> insert (level x order) x) q xs - - go q1 = case minView q1 of - Nothing -> return () - Just (a, q2) -> do - continue <- f a - case continue of - Done -> go q2 - Children -> go $ insertList (children deps a) q2 - --- | Queue for traversing dependencies. --- --- The 'Int' is a key supply for the priority search queue. -data DepsQueue a = DQ !(Q.IntPSQ Level a) !(Set a) Int - -emptyQ :: DepsQueue a -emptyQ = DQ Q.empty Set.empty 0 - -insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a -insert k a q@(DQ queue seen n) = {-# SCC insert #-} - if a `Set.member` seen - then q - else DQ (Q.insert (n+1) k a queue) (Set.insert a seen) (n+1) - -minView :: DepsQueue a -> Maybe (a, DepsQueue a) -minView (DQ queue seen n) = {-# SCC minView #-} case Q.minView queue of - Nothing -> Nothing - Just (_, _, a, queue2) -> Just (a, DQ queue2 seen n) - -{----------------------------------------------------------------------------- - Small tests -------------------------------------------------------------------------------} -test1 = id - . changeParent 'C' 'A' - . addChild 'C' 'D' - . addChild 'B' 'C' - . addChild 'B' 'D' - . addChild 'A' 'B' - . addChild 'a' 'B' - $ empty - -{- test2 = - a - / \ - b d A - | | | - c e B - \ / \ / - f g - \ / - h - --} -test2 = id - . addChild 'g' 'h' . addChild 'e' 'g' - . addChild 'B' 'g' . addChild 'A' 'B' - . addChild 'f' 'h' - . addChild 'e' 'f' . addChild 'd' 'e' . addChild 'a' 'd' - . addChild 'c' 'f' . addChild 'b' 'c' . addChild 'a' 'b' - $ empty - -test3 = changeParent 'A' 'f' $ test2 - -listChildren :: (Eq a, Hashable a) => Deps a -> a -> [a] -listChildren deps x = snd $ runWriter $ traverseDependencies f deps [x] - where f x = tell [x] >> return Children - diff --git a/src/Reactive/Banana/Prim/Evaluation.hs b/src/Reactive/Banana/Prim/Evaluation.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Evaluation.hs +++ /dev/null @@ -1,75 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo, BangPatterns #-} -module Reactive.Banana.Prim.Evaluation where - -import qualified Control.Exception as Strict (evaluate) -import Data.Monoid -import Data.List (foldl') - -import qualified Reactive.Banana.Prim.Dated as Dated -import qualified Reactive.Banana.Prim.Dependencies as Deps -import Reactive.Banana.Prim.Order -import Reactive.Banana.Prim.Plumbing -import Reactive.Banana.Prim.Types - -{----------------------------------------------------------------------------- - Graph evaluation -------------------------------------------------------------------------------} --- | Evaluate all the pulses in the graph, --- Rebuild the graph as necessary and update the latch values. -step :: Inputs -> Step -step (pulse1, roots) state1 = {-# SCC step #-} mdo - let graph1 = nGraph state1 - latch1 = nLatchValues state1 - time1 = nTime state1 - - -- evaluate pulses while recalculating some latch values - ((_, latchUpdates, output), state2) - <- runBuildIO state1 - $ runEvalP pulse1 - $ evaluatePulses graph1 roots - - let - -- updated graph dependencies - graph2 = nGraph state2 - -- update latch values from accumulations - latch2 = appEndo latchUpdates $ nLatchValues state2 - -- calculate output actions, possibly recalculating more latch values - (actions, latch3) = Dated.runDated output latch2 - - -- make sure that the latch values are in WHNF - Strict.evaluate $ {-# SCC evaluate #-} latch3 - return (actions, Network - { nGraph = graph2 - , nLatchValues = latch3 - , nTime = Dated.next time1 - }) - - -type Result = (EvalL, [(Position, EvalO)]) -type Q = Deps.DepsQueue - --- | Update all pulses in the graph, starting from a given set of nodes -evaluatePulses :: Graph -> [SomeNode] -> EvalP Result -evaluatePulses Graph { grDeps = deps } roots = - go mempty [] $ insertList roots Deps.emptyQ - where - order = Deps.dOrder deps - - go :: EvalL -> [(Position,EvalO)] -> Q SomeNode -> EvalP Result - go el eo !q1 = {-# SCC go #-} case Deps.minView q1 of - Nothing -> return (el, eo) - Just (a, q2) -> case a of - P p -> evaluateP p >>= \c -> case c of - Deps.Children -> go el eo $ insertList (Deps.children deps a) q2 - Deps.Done -> go el eo q2 - L l -> evaluateL l >>= \x -> go (el `mappend` x) eo q2 - O o -> evaluateO o >>= \x -> go el ((positionO o, x):eo) q2 - - insertList :: [SomeNode] -> Q SomeNode -> Q SomeNode - insertList xs q = {-# SCC insertList #-} - foldl' (\q node -> Deps.insert (level node order) node q) q xs - - diff --git a/src/Reactive/Banana/Prim/High/Cached.hs b/src/Reactive/Banana/Prim/High/Cached.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/High/Cached.hs @@ -0,0 +1,64 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +{-# LANGUAGE RecursiveDo #-} +module Reactive.Banana.Prim.High.Cached ( + -- | Utility for executing monadic actions once + -- and then retrieving values from a cache. + -- + -- Very useful for observable sharing. + Cached, runCached, cache, fromPure, don'tCache, + liftCached1, liftCached2, + ) where + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) + +{----------------------------------------------------------------------------- + Cache type +------------------------------------------------------------------------------} +data Cached m a = Cached (m a) + +runCached :: Cached m a -> m a +runCached (Cached x) = x + +-- | An action whose result will be cached. +-- Executing the action the first time in the monad will +-- execute the side effects. From then on, +-- only the generated value will be returned. +{-# NOINLINE cache #-} +cache :: (MonadFix m, MonadIO m) => m a -> Cached m a +cache m = unsafePerformIO $ do + key <- liftIO $ newIORef Nothing + return $ Cached $ do + ma <- liftIO $ readIORef key -- read the cached result + case ma of + Just a -> return a -- return the cached result. + Nothing -> mdo + liftIO $ -- write the result already + writeIORef key (Just a) + a <- m -- evaluate + return a + +-- | Return a pure value. Doesn't make use of the cache. +fromPure :: Monad m => a -> Cached m a +fromPure = Cached . return + +-- | Lift an action that is /not/ cached, for instance because it is idempotent. +don'tCache :: Monad m => m a -> Cached m a +don'tCache = Cached + +liftCached1 :: (MonadFix m, MonadIO m) => + (a -> m b) -> Cached m a -> Cached m b +liftCached1 f ca = cache $ do + a <- runCached ca + f a + +liftCached2 :: (MonadFix m, MonadIO m) => + (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c +liftCached2 f ca cb = cache $ do + a <- runCached ca + b <- runCached cb + f a b diff --git a/src/Reactive/Banana/Prim/High/Combinators.hs b/src/Reactive/Banana/Prim/High/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/High/Combinators.hs @@ -0,0 +1,260 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +{-# LANGUAGE FlexibleInstances, NamedFieldPuns, NoMonomorphismRestriction #-} +module Reactive.Banana.Prim.High.Combinators where + +import Control.Exception +import Control.Concurrent.MVar +import Control.Event.Handler +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader +import Data.IORef +import qualified Reactive.Banana.Prim.Mid as Prim +import Reactive.Banana.Prim.High.Cached + +type Build = Prim.Build +type Latch a = Prim.Latch a +type Pulse a = Prim.Pulse a +type Future = Prim.Future + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +type Behavior a = Cached Moment (Latch a, Pulse ()) +type Event a = Cached Moment (Pulse a) +type Moment = ReaderT EventNetwork Prim.Build + +liftBuild :: Build a -> Moment a +liftBuild = lift + +{----------------------------------------------------------------------------- + Interpretation +------------------------------------------------------------------------------} +interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] +interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined + where + g pulse = runCached =<< f (Prim.fromPure pulse) + -- Ignore any addHandler inside the Moment + +{----------------------------------------------------------------------------- + IO +------------------------------------------------------------------------------} +-- | Data type representing an event network. +data EventNetwork = EventNetwork + { actuated :: IORef Bool + , size :: IORef Int + , s :: MVar Prim.Network + } + +runStep :: EventNetwork -> Prim.Step -> IO () +runStep EventNetwork{ actuated, s, size } f = whenFlag actuated $ do + output <- mask $ \restore -> do + s1 <- takeMVar s -- read and take lock + -- pollValues <- sequence polls -- poll mutable data + (output, s2) <- + restore (f s1) -- calculate new state + `onException` putMVar s s1 -- on error, restore the original state + putMVar s s2 -- write state + writeIORef size =<< Prim.getSize s2 + return output + output -- run IO actions afterwards + where + whenFlag flag action = readIORef flag >>= \b -> when b action + +getSize :: EventNetwork -> IO Int +getSize EventNetwork{size} = readIORef size + +actuate :: EventNetwork -> IO () +actuate EventNetwork{ actuated } = writeIORef actuated True + +pause :: EventNetwork -> IO () +pause EventNetwork{ actuated } = writeIORef actuated False + +-- | Compile to an event network. +compile :: Moment () -> IO EventNetwork +compile setup = do + actuated <- newIORef False -- flag to set running status + s <- newEmptyMVar -- setup callback machinery + size <- newIORef 0 + + let eventNetwork = EventNetwork{ actuated, s, size } + + (_output, s0) <- -- compile initial graph + Prim.compile (runReaderT setup eventNetwork) =<< Prim.emptyNetwork + putMVar s s0 -- set initial state + writeIORef size =<< Prim.getSize s0 + + return eventNetwork + +fromAddHandler :: AddHandler a -> Moment (Event a) +fromAddHandler addHandler = do + (p, fire) <- liftBuild Prim.newInput + network <- ask + _unregister <- liftIO $ register addHandler $ runStep network . fire + return $ Prim.fromPure p + +addReactimate :: Event (Future (IO ())) -> Moment () +addReactimate e = do + network <- ask + liftBuild $ Prim.buildLater $ do + -- Run cached computation later to allow more recursion with `Moment` + p <- runReaderT (runCached e) network + Prim.addHandler p id + +fromPoll :: IO a -> Moment (Behavior a) +fromPoll poll = do + a <- liftIO poll + e <- liftBuild $ do + p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP + return $ Prim.fromPure p + stepperB a e + +liftIONow :: IO a -> Moment a +liftIONow = liftIO + +liftIOLater :: IO () -> Moment () +liftIOLater = lift . Prim.liftBuild . Prim.liftIOLater + +imposeChanges :: Behavior a -> Event () -> Behavior a +imposeChanges = liftCached2 $ \(l1,_) p2 -> return (l1,p2) + +{----------------------------------------------------------------------------- + Combinators - basic +------------------------------------------------------------------------------} +never :: Event a +never = don'tCache $ liftBuild Prim.neverP + +mergeWith + :: (a -> c) + -> (b -> c) + -> (a -> b -> c) + -> Event a + -> Event b + -> Event c +mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y)) + + +filterJust :: Event (Maybe a) -> Event a +filterJust = liftCached1 $ liftBuild . Prim.filterJustP + +mapE :: (a -> b) -> Event a -> Event b +mapE f = liftCached1 $ liftBuild . Prim.mapP f + +applyE :: Behavior (a -> b) -> Event a -> Event b +applyE = liftCached2 $ \(~(lf,_)) px -> liftBuild $ Prim.applyP lf px + +changesB :: Behavior a -> Event (Future a) +changesB = liftCached1 $ \(~(lx,px)) -> liftBuild $ Prim.tagFuture lx px + +pureB :: a -> Behavior a +pureB a = cache $ do + p <- runCached never + return (Prim.pureL a, p) + +applyB :: Behavior (a -> b) -> Behavior a -> Behavior b +applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do + p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2 + let l3 = Prim.applyL l1 l2 + return (l3,p3) + +mapB :: (a -> b) -> Behavior a -> Behavior b +mapB f = applyB (pureB f) + +{----------------------------------------------------------------------------- + Combinators - accumulation +------------------------------------------------------------------------------} +-- Make sure that the cached computation (Event or Behavior) +-- is executed eventually during this moment. +trim :: Cached Moment a -> Moment (Cached Moment a) +trim b = do + liftBuildFun Prim.buildLater $ void $ runCached b + return b + +-- Cache a computation at this moment in time +-- and make sure that it is performed in the Build monad eventually +cacheAndSchedule :: Moment a -> Moment (Cached Moment a) +cacheAndSchedule m = ask >>= \r -> liftBuild $ do + let c = cache (const m r) -- prevent let-floating! + Prim.buildLater $ void $ runReaderT (runCached c) r + return c + +stepperB :: a -> Event a -> Moment (Behavior a) +stepperB a e = cacheAndSchedule $ do + p0 <- runCached e + liftBuild $ do + p1 <- Prim.mapP const p0 + p2 <- Prim.mapP (const ()) p1 + (l,_) <- Prim.accumL a p1 + return (l,p2) + +accumE :: a -> Event (a -> a) -> Moment (Event a) +accumE a e1 = cacheAndSchedule $ do + p0 <- runCached e1 + liftBuild $ do + (_,p1) <- Prim.accumL a p0 + return p1 + +{----------------------------------------------------------------------------- + Combinators - dynamic event switching +------------------------------------------------------------------------------} +liftBuildFun :: (Build a -> Build b) -> Moment a -> Moment b +liftBuildFun f m = do + r <- ask + liftBuild $ f $ runReaderT m r + +valueB :: Behavior a -> Moment a +valueB b = do + ~(l,_) <- runCached b + liftBuild $ Prim.readLatch l + +initialBLater :: Behavior a -> Moment a +initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB + +executeP :: Pulse (Moment a) -> Moment (Pulse a) +executeP p1 = do + r <- ask + liftBuild $ do + p2 <- Prim.mapP runReaderT p1 + Prim.executeP p2 r + +observeE :: Event (Moment a) -> Event a +observeE = liftCached1 executeP + +executeE :: Event (Moment a) -> Moment (Event a) +executeE e = do + -- Run cached computation later to allow more recursion with `Moment` + p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e + return $ fromPure p + +switchE :: Event a -> Event (Event a) -> Moment (Event a) +switchE e0 e = ask >>= \r -> cacheAndSchedule $ do + p0 <- runCached e0 + p1 <- runCached e + liftBuild $ do + p2 <- Prim.mapP (runReaderT . runCached) p1 + + p3 <- Prim.executeP p2 r + Prim.switchP p0 p3 + +switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a) +switchB b e = ask >>= \r -> cacheAndSchedule $ do + ~(l0,p0) <- runCached b + p1 <- runCached e + liftBuild $ do + p2 <- Prim.mapP (runReaderT . runCached) p1 + p3 <- Prim.executeP p2 r + + lr <- Prim.switchL l0 =<< Prim.mapP fst p3 + -- TODO: switch away the initial behavior + let c1 = p0 -- initial behavior changes + c2 <- Prim.mapP (const ()) p3 -- or switch happens + never <- Prim.neverP + c3 <- Prim.switchP never =<< Prim.mapP snd p3 -- or current behavior changes + pr <- merge c1 =<< merge c2 c3 + return (lr, pr) + +merge :: Pulse () -> Pulse () -> Build (Pulse ()) +merge = Prim.mergeWithP Just Just (\_ _ -> Just ()) diff --git a/src/Reactive/Banana/Prim/IO.hs b/src/Reactive/Banana/Prim/IO.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/IO.hs +++ /dev/null @@ -1,51 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Reactive.Banana.Prim.IO where - -import Data.Functor -import Data.Unique.Really -import qualified Data.Vault.Strict as Strict -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) - -import Reactive.Banana.Prim.Combinators (mapP) -import Reactive.Banana.Prim.Dependencies (maybeContinue) -import Reactive.Banana.Prim.Evaluation (step) -import Reactive.Banana.Prim.Plumbing -import Reactive.Banana.Prim.Types - -debug s = id - -{----------------------------------------------------------------------------- - Primitives connecting to the outside world -------------------------------------------------------------------------------} --- | Create a new pulse in the network and a function to trigger it. --- --- Together with 'addHandler', this function can be used to operate with --- pulses as with standard callback-based events. -newInput :: Lazy.Key a -> Build (Pulse a, a -> Step) -newInput key = unsafePerformIO $ do - uid <- newUnique - let pulse = Pulse - { evaluateP = maybeContinue <$> readPulseP pulse - , getValueP = Lazy.lookup key - , uidP = uid - , nameP = "newInput" - } - return $ do - always <- alwaysP - let inputs a = (Lazy.insert key a Lazy.empty, [P pulse, P always]) - return (pulse, step . inputs) - --- | Register a handler to be executed whenever a pulse occurs. --- --- The pulse may refer to future latch values. -addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build () -addHandler p1 f = do - p2 <- mapP (fmap f) p1 - addOutput p2 - --- | Read the value of a 'Latch' at a particular moment in time. -readLatch :: Latch a -> Build a -readLatch = readLatchB diff --git a/src/Reactive/Banana/Prim/Low/Graph.hs b/src/Reactive/Banana/Prim/Low/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Low/Graph.hs @@ -0,0 +1,300 @@ +{-# language BangPatterns #-} +{-# language NamedFieldPuns #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Low.Graph + ( Graph + , empty + , getOutgoing + , getIncoming + , size + , edgeCount + , listConnectedVertices + + , deleteVertex + , insertEdge + , deleteEdge + , clearPredecessors + , collectGarbage + + , topologicalSort + , Step (..) + , walkSuccessors + , walkSuccessors_ + + -- * Internal + , Level + , getLevel + + -- * Debugging + , showDot + ) where + +import Data.Functor.Identity + ( Identity (..) ) +import Data.Hashable + ( Hashable ) +import Data.Maybe + ( fromMaybe ) +import Reactive.Banana.Prim.Low.GraphTraversal + ( reversePostOrder ) + +import qualified Data.List as L +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.PQueue.Prio.Min as Q + +type Queue = Q.MinPQueue +type Map = Map.HashMap +type Set = Set.HashSet + +{----------------------------------------------------------------------------- + Levels +------------------------------------------------------------------------------} +-- | 'Level's are used to keep track of the order of vertices — +-- Lower levels come first. +type Level = Int + +ground :: Level +ground = 0 + +{----------------------------------------------------------------------------- + Graph +------------------------------------------------------------------------------} +{- | A directed graph +whose set of vertices is the set of all values of the type @v@ +and whose edges are associated with data of type @e@. + +Note that a 'Graph' does not have a notion of vertex membership +— by design, /all/ values of the type @v@ are vertices of the 'Graph'. +The main purpose of 'Graph' is to keep track of directed edges between +vertices; a vertex with at least one edge incident on it is called +a /connected vertex/. +For efficiency, only the connected vertices are stored. +-} +data Graph v e = Graph + { -- | Mapping from each vertex to its direct successors + -- (possibly empty). + outgoing :: !(Map v (Map v e)) + + -- | Mapping from each vertex to its direct predecessors + -- (possibly empty). + , incoming :: !(Map v (Map v e)) + + -- | Mapping from each vertex to its 'Level'. + -- Invariant: If x precedes y, then x has a lower level than y. + , levels :: !(Map v Level) + } deriving (Eq, Show) + +-- | The graph with no edges. +empty :: Graph v e +empty = Graph + { outgoing = Map.empty + , incoming = Map.empty + , levels = Map.empty + } + +-- | Get all direct successors of a vertex in a 'Graph'. +getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)] +getOutgoing Graph{outgoing} x = + map shuffle $ Map.toList $ fromMaybe Map.empty $ Map.lookup x outgoing + where + shuffle (x,y) = (y,x) + +-- | Get all direct predecessors of a vertex in a 'Graph'. +getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)] +getIncoming Graph{incoming} x = + Map.toList $ fromMaybe Map.empty $ Map.lookup x incoming + +-- | Get the 'Level' of a vertex in a 'Graph'. +getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level +getLevel Graph{levels} x = fromMaybe ground $ Map.lookup x levels + +-- | List all connected vertices, +-- i.e. vertices on which at least one edge is incident. +listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v] +listConnectedVertices Graph{incoming,outgoing} = + Map.keys $ (() <$ outgoing) `Map.union` (() <$ incoming) + +-- | Number of connected vertices, +-- i.e. vertices on which at least one edge is incident. +size :: (Eq v, Hashable v) => Graph v e -> Int +size Graph{incoming,outgoing} = + Map.size $ (() <$ outgoing) `Map.union` (() <$ incoming) + +-- | Number of edges. +edgeCount :: (Eq v, Hashable v) => Graph v e -> Int +edgeCount Graph{incoming,outgoing} = + (count incoming + count outgoing) `div` 2 + where + count = Map.foldl' (\a v -> Map.size v + a) 0 + +{----------------------------------------------------------------------------- + Insertion +------------------------------------------------------------------------------} +-- | Insert an edge from the first to the second vertex into the 'Graph'. +insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e +insertEdge (x,y) exy g0@Graph{..} = Graph + { outgoing + = Map.insertWith (\new old -> new <> old) x (Map.singleton y exy) + $ insertDefaultIfNotMember y Map.empty + $ outgoing + , incoming + = Map.insertWith (\new old -> new <> old) y (Map.singleton x exy) + . insertDefaultIfNotMember x Map.empty + $ incoming + , levels + = adjustLevels + $ levels0 + } + where + getLevel z = fromMaybe ground . Map.lookup z + levels0 + = insertDefaultIfNotMember x (ground-1) + . insertDefaultIfNotMember y ground + $ levels + + levelDifference = getLevel y levels0 - 1 - getLevel x levels0 + adjustLevel g x = Map.adjust (+ levelDifference) x g + adjustLevels ls + | levelDifference >= 0 = ls + | otherwise = L.foldl' adjustLevel ls predecessors + where + Identity predecessors = + reversePostOrder [x] (Identity . map fst . getIncoming g0) + +-- Helper function: Insert a default value if the key is not a member yet +insertDefaultIfNotMember + :: (Eq k, Hashable k) + => k -> a -> Map k a -> Map k a +insertDefaultIfNotMember x def = Map.insertWith (\_ old -> old) x def + +{----------------------------------------------------------------------------- + Deletion +------------------------------------------------------------------------------} +-- | TODO: Not implemented. +deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e +deleteEdge (x,y) g = Graph + { outgoing = undefined x g + , incoming = undefined y g + , levels = undefined + } + +-- | Remove all edges incident on this vertex from the 'Graph'. +deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +deleteVertex x = clearLevels . clearPredecessors x . clearSuccessors x + where + clearLevels g@Graph{levels} = g{levels = Map.delete x levels} + +-- | Remove all the edges that connect the given vertex to its predecessors. +clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +clearPredecessors x g@Graph{..} = g + { outgoing = foldr ($) outgoing + [ Map.adjust (Map.delete x) z | (z,_) <- getIncoming g x ] + , incoming = Map.delete x incoming + } + +-- | Remove all the edges that connect the given vertex to its successors. +clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e +clearSuccessors x g@Graph{..} = g + { outgoing = Map.delete x outgoing + , incoming = foldr ($) incoming + [ Map.adjust (Map.delete x) z | (_,z) <- getOutgoing g x ] + } + +-- | Apply `deleteVertex` to all vertices which are not predecessors +-- of any of the vertices in the given list. +collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e +collectGarbage roots g@Graph{incoming,outgoing} = g + { incoming = Map.filterWithKey (\v _ -> isReachable v) incoming + -- incoming edges of reachable members are reachable by definition + , outgoing + = Map.map (Map.filterWithKey (\v _ -> isReachable v)) + $ Map.filterWithKey (\v _ -> isReachable v) outgoing + } + where + isReachable x = x `Set.member` reachables + reachables + = Set.fromList . runIdentity + $ reversePostOrder roots + $ Identity . map fst . getIncoming g + +{----------------------------------------------------------------------------- + Topological sort +------------------------------------------------------------------------------} +-- | If the 'Graph' is acyclic, return a topological sort, +-- that is a linear ordering of its connected vertices such that +-- each vertex occurs before its successors. +-- +-- (Vertices that are not connected are not listed in the topological sort.) +-- +-- https://en.wikipedia.org/wiki/Topological_sorting +topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v] +topologicalSort g@Graph{incoming} = + runIdentity $ reversePostOrder roots (Identity . map snd . getOutgoing g) + where + -- all vertices that have no (direct) predecessors + roots = [ x | (x,preds) <- Map.toList incoming, null preds ] + +data Step = Next | Stop + +-- | Starting from a list of vertices without predecessors, +-- walk through all successors, but in such a way that every vertex +-- is visited before its predecessors. +-- For every vertex, if the function returns `Next`, then +-- the successors are visited, otherwise the walk at the vertex +-- stops prematurely. +-- +-- > topologicalSort g = +-- > runIdentity $ walkSuccessors (roots g) (pure Next) g +-- +walkSuccessors + :: forall v e m. (Monad m, Eq v, Hashable v) + => [v] -> (v -> m Step) -> Graph v e -> m [v] +walkSuccessors xs step g = go (Q.fromList $ zipLevels xs) Set.empty [] + where + zipLevels vs = [(getLevel g v, v) | v <- vs] + + go :: Queue Level v -> Set v -> [v] -> m [v] + go q0 seen visits = case Q.minView q0 of + Nothing -> pure $ reverse visits + Just (v,q1) + | v `Set.member` seen -> go q1 seen visits + | otherwise -> do + next <- step v + let q2 = case next of + Stop -> q1 + Next -> + let successors = zipLevels $ map snd $ getOutgoing g v + in insertList q1 successors + go q2 (Set.insert v seen) (v:visits) + + +insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v +insertList = L.foldl' (\q (k,v) -> Q.insert k v q) + +walkSuccessors_ + :: (Monad m, Eq v, Hashable v) + => [v] -> (v -> m Step) -> Graph v e -> m () +walkSuccessors_ xs step g = walkSuccessors xs step g >> pure () + +{----------------------------------------------------------------------------- + Debugging +------------------------------------------------------------------------------} +-- | Map to a string in @graphviz@ dot file format. +showDot + :: (Eq v, Hashable v) + => (v -> String) -> Graph v e -> String +showDot fv g = unlines $ + [ "digraph mygraph {" + , " node [shape=box];" + ] <> map showVertex (listConnectedVertices g) + <> ["}"] + where + showVertex x = + concat [ " " <> showEdge x y <> "; " | (_,y) <- getOutgoing g x ] + showEdge x y = escape x <> " -> " <> escape y + escape = show . fv diff --git a/src/Reactive/Banana/Prim/Low/GraphGC.hs b/src/Reactive/Banana/Prim/Low/GraphGC.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Low/GraphGC.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Low.GraphGC + ( GraphGC + , listReachableVertices + , getSize + , new + , insertEdge + , clearPredecessors + + , Step (..) + , walkSuccessors + , walkSuccessors_ + + , removeGarbage + + -- * Debugging + , printDot + ) where + +import Control.Applicative + ( (<|>) ) +import Control.Monad + ( unless ) +import Data.IORef + ( IORef, atomicModifyIORef', newIORef, readIORef ) +import Data.Maybe + ( fromJust ) +import Data.Unique.Really + ( Unique ) +import Reactive.Banana.Prim.Low.Graph + ( Graph, Step ) +import Reactive.Banana.Prim.Low.Ref + ( Ref, WeakRef ) + +import qualified Control.Concurrent.STM as STM +import qualified Data.HashMap.Strict as Map +import qualified Reactive.Banana.Prim.Low.Graph as Graph +import qualified Reactive.Banana.Prim.Low.Ref as Ref + +type Map = Map.HashMap + +{----------------------------------------------------------------------------- + GraphGC +------------------------------------------------------------------------------} +type WeakEdge v = WeakRef v + +-- Graph data +data GraphD v = GraphD + { graph :: !(Graph Unique (WeakEdge v)) + , references :: !(Map Unique (WeakRef v)) + } + +{- | A directed graph whose edges are mutable + and whose vertices are subject to garbage collection. + + The vertices of the graph are mutable references of type 'Ref v'. + + + Generally, the vertices of the graph are not necessarily kept reachable + by the 'GraphGC' data structure + — they need to be kept reachable by other parts of your program. + + That said, the edges in the graph do introduce additional reachability + between vertices: + Specifically, when an edge (x,y) is present in the graph, + then the head @y@ will keep the tail @x@ reachable. + (But the liveness of @y@ needs to come from elsewhere, e.g. another edge.) + Use 'insertEdge' to insert an edge. + + Moreover, when a vertex is removed because it is no longer reachable, + then all edges to and from that vertex will also be removed. + In turn, this may cause further vertices and edges to be removed. + + Concerning garbage collection: + Note that vertices and edges will not be removed automatically + when the Haskell garbage collector runs — + they will be marked as garbage by the Haskell runtime, + but the actual removal of garbage needs + to be done explicitly by calling 'removeGarbage'. + This procedure makes it easier to reason about the state of the 'GraphGC' + during a call to e.g. 'walkSuccessors'. +-} +data GraphGC v = GraphGC + { graphRef :: IORef (GraphD v) + , deletions :: STM.TQueue Unique + } + +-- | Create a new 'GraphGC'. +new :: IO (GraphGC v) +new = GraphGC <$> newIORef newGraphD <*> STM.newTQueueIO + where + newGraphD = GraphD + { graph = Graph.empty + , references = Map.empty + } + +getSize :: GraphGC v -> IO Int +getSize GraphGC{graphRef} = Graph.size . graph <$> readIORef graphRef + +-- | List all vertices that are reachable and have at least +-- one edge incident on them. +-- TODO: Is that really what the function does? +listReachableVertices :: GraphGC v -> IO [Ref v] +listReachableVertices GraphGC{graphRef} = do + GraphD{references} <- readIORef graphRef + concat . Map.elems <$> traverse inspect references + where + inspect ref = do + mv <- Ref.deRefWeak ref + pure $ case mv of + Nothing -> [] + Just r -> [r] + +-- | Insert an edge from the first vertex to the second vertex. +insertEdge :: (Ref v, Ref v) -> GraphGC v -> IO () +insertEdge (x,y) g@GraphGC{graphRef} = do + (xKnown, yKnown) <- + insertTheEdge =<< makeWeakPointerThatRepresentsEdge + unless xKnown $ Ref.addFinalizer x (finalizeVertex g ux) + unless yKnown $ Ref.addFinalizer y (finalizeVertex g uy) + where + ux = Ref.getUnique x + uy = Ref.getUnique y + + makeWeakPointerThatRepresentsEdge = + Ref.mkWeak y x Nothing + + insertTheEdge we = atomicModifyIORef' graphRef $ + \GraphD{graph,references} -> + ( GraphD + { graph + = Graph.insertEdge (ux,uy) we + $ graph + , references + = Map.insert ux (Ref.getWeakRef x) + . Map.insert uy (Ref.getWeakRef y) + $ references + } + , ( ux `Map.member` references + , uy `Map.member` references + ) + ) + +-- | Remove all the edges that connect the vertex to its predecessors. +clearPredecessors :: Ref v -> GraphGC v -> IO () +clearPredecessors x GraphGC{graphRef} = do + g <- atomicModifyIORef' graphRef $ \g -> (removeIncomingEdges g, g) + finalizeIncomingEdges g + where + removeIncomingEdges g@GraphD{graph} = + g{ graph = Graph.clearPredecessors (Ref.getUnique x) graph } + finalizeIncomingEdges GraphD{graph} = + mapM_ (Ref.finalize . snd) . Graph.getIncoming graph $ Ref.getUnique x + +-- | Walk through all successors. See 'Graph.walkSuccessors'. +walkSuccessors + :: Monad m + => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m [WeakRef v]) +walkSuccessors roots step GraphGC{..} = do + GraphD{graph,references} <- readIORef graphRef + let rootsMap = Map.fromList + [ (Ref.getUnique r, Ref.getWeakRef r) | r <- roots ] + fromUnique u = fromJust $ + Map.lookup u references <|> Map.lookup u rootsMap + pure + . fmap (map fromUnique) + . Graph.walkSuccessors (map Ref.getUnique roots) (step . fromUnique) + $ graph + +-- | Walk through all successors. See 'Graph.walkSuccessors_'. +walkSuccessors_ :: + Monad m => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ()) +walkSuccessors_ roots step g = do + action <- walkSuccessors roots step g + pure $ action >> pure () + +{----------------------------------------------------------------------------- + Garbage Collection +------------------------------------------------------------------------------} +-- | Explicitly remove all vertices and edges that have been marked +-- as garbage by the Haskell garbage collector. +removeGarbage :: GraphGC v -> IO () +removeGarbage g@GraphGC{deletions} = do + xs <- STM.atomically $ STM.flushTQueue deletions + mapM_ (deleteVertex g) xs + +-- Delete all edges associated with a vertex from the 'GraphGC'. +-- +-- TODO: Check whether using an IORef is thread-safe. +-- I think it's fine because we have a single thread that performs deletions. +deleteVertex :: GraphGC v -> Unique -> IO () +deleteVertex GraphGC{graphRef} x = + atomicModifyIORef'_ graphRef $ \GraphD{graph,references} -> GraphD + { graph = Graph.deleteVertex x graph + , references = Map.delete x references + } + +-- Finalize a vertex +finalizeVertex :: GraphGC v -> Unique -> IO () +finalizeVertex GraphGC{deletions} = + STM.atomically . STM.writeTQueue deletions + +{----------------------------------------------------------------------------- + Debugging +------------------------------------------------------------------------------} +-- | Show the underlying graph in @graphviz@ dot file format. +printDot :: (Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String +printDot format GraphGC{graphRef} = do + GraphD{graph,references} <- readIORef graphRef + strings <- Map.traverseWithKey format references + pure $ Graph.showDot (strings Map.!) graph + +{----------------------------------------------------------------------------- + Helper functions +------------------------------------------------------------------------------} +-- | Atomically modify an 'IORef' without returning a result. +atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO () +atomicModifyIORef'_ ref f = atomicModifyIORef' ref $ \x -> (f x, ()) diff --git a/src/Reactive/Banana/Prim/Low/GraphTraversal.hs b/src/Reactive/Banana/Prim/Low/GraphTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Low/GraphTraversal.hs @@ -0,0 +1,41 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Low.GraphTraversal + ( GraphM + , reversePostOrder1 + , reversePostOrder + ) where + +import Data.Hashable +import qualified Data.HashSet as Set + +{----------------------------------------------------------------------------- + Graph traversal +------------------------------------------------------------------------------} +-- | Graph represented as map from a vertex to its direct successors. +type GraphM m a = a -> m [a] + +-- | Computes the reverse post-order, +-- listing all (transitive) successor of a node. +-- +-- Each vertex is listed *before* all its direct successors have been listed. +reversePostOrder1 :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a] +reversePostOrder1 x = reversePostOrder [x] + +-- | Reverse post-order from multiple vertices. +-- +-- INVARIANT: For this to be a valid topological order, +-- none of the vertices may have a direct predecessor. +reversePostOrder :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a] +reversePostOrder xs successors = fst <$> go xs [] Set.empty + where + go [] rpo visited = return (rpo, visited) + go (x:xs) rpo visited + | x `Set.member` visited = go xs rpo visited + | otherwise = do + xs' <- successors x + -- visit all direct successors + (rpo', visited') <- go xs' rpo (Set.insert x visited) + -- prepend this vertex as all direct successors have been visited + go xs (x:rpo') visited' diff --git a/src/Reactive/Banana/Prim/Low/OrderedBag.hs b/src/Reactive/Banana/Prim/Low/OrderedBag.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Low/OrderedBag.hs @@ -0,0 +1,42 @@ +{----------------------------------------------------------------------------- + reactive-banana + + Implementation of a bag whose elements are ordered by arrival time. +------------------------------------------------------------------------------} +{-# LANGUAGE TupleSections #-} +module Reactive.Banana.Prim.Low.OrderedBag where + +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import Data.List ( foldl', sortBy ) +import Data.Maybe +import Data.Ord + +{----------------------------------------------------------------------------- + Ordered Bag +------------------------------------------------------------------------------} +type Position = Integer + +data OrderedBag a = OB !(Map.HashMap a Position) !Position + +empty :: OrderedBag a +empty = OB Map.empty 0 + +-- | Add an element to an ordered bag after all the others. +-- Does nothing if the element is already in the bag. +insert :: (Eq a, Hashable a) => OrderedBag a -> a -> OrderedBag a +insert (OB xs n) x = OB (Map.insertWith (\_new old -> old) x n xs) (n+1) + +-- | Add a sequence of elements to an ordered bag. +-- +-- The ordering is left-to-right. For example, the head of the sequence +-- comes after all elements in the bag, +-- but before the other elements in the sequence. +inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a +inserts = foldl' insert + +-- | Reorder a list of elements to appear as they were inserted into the bag. +-- Remove any elements from the list that do not appear in the bag. +inOrder :: (Eq a, Hashable a) => [(a,b)] -> OrderedBag a -> [(a,b)] +inOrder xs (OB bag _) = map snd $ sortBy (comparing fst) $ + mapMaybe (\x -> (,x) <$> Map.lookup (fst x) bag) xs diff --git a/src/Reactive/Banana/Prim/Low/Ref.hs b/src/Reactive/Banana/Prim/Low/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Low/Ref.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE UnboxedTuples #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Low.Ref + ( -- * Mutable references with 'Unique' + Ref + , getUnique + , new + , equal + , read + , put + , modify' + + -- * Garbage collection and weak pointers to 'Ref' + , addFinalizer + , getWeakRef + + , WeakRef + , mkWeak + , deRefWeak + , deRefWeaks + , finalize + ) where + +import Prelude hiding ( read ) + +import Control.DeepSeq + ( NFData (..) ) +import Control.Monad + ( void ) +import Control.Monad.IO.Class + ( MonadIO (liftIO) ) +import Data.Hashable + ( Hashable (..) ) +import Data.IORef + ( IORef, newIORef, readIORef, writeIORef ) +import Data.Maybe + ( catMaybes ) +import Data.Unique.Really + ( Unique, newUnique ) + +import qualified System.Mem.Weak as Weak +import qualified GHC.Base as GHC +import qualified GHC.IORef as GHC +import qualified GHC.STRef as GHC +import qualified GHC.Weak as GHC + +{----------------------------------------------------------------------------- + Ref +------------------------------------------------------------------------------} +-- | A mutable reference which has a 'Unique' associated with it. +data Ref a = Ref + !Unique -- Unique associated to the 'Ref' + !(IORef a) -- 'IORef' that stores the value of type 'a' + !(WeakRef a) -- For convenience, a weak pointer to itself + +instance NFData (Ref a) where rnf (Ref _ _ _) = () + +instance Eq (Ref a) where (==) = equal + +instance Hashable (Ref a) where hashWithSalt s (Ref u _ _) = hashWithSalt s u + +getUnique :: Ref a -> Unique +getUnique (Ref u _ _) = u + +getWeakRef :: Ref a -> WeakRef a +getWeakRef (Ref _ _ w) = w + +equal :: Ref a -> Ref b -> Bool +equal (Ref ua _ _) (Ref ub _ _) = ua == ub + +new :: MonadIO m => a -> m (Ref a) +new a = liftIO $ mdo + ra <- newIORef a + result <- Ref <$> newUnique <*> pure ra <*> pure wa + wa <- mkWeakIORef ra result Nothing + pure result + +read :: MonadIO m => Ref a -> m a +read ~(Ref _ r _) = liftIO $ readIORef r + +put :: MonadIO m => Ref a -> a -> m () +put ~(Ref _ r _) = liftIO . writeIORef r + +-- | Strictly modify a 'Ref'. +modify' :: MonadIO m => Ref a -> (a -> a) -> m () +modify' ~(Ref _ r _) f = liftIO $ + readIORef r >>= \x -> writeIORef r $! f x + +{----------------------------------------------------------------------------- + Weak pointers +------------------------------------------------------------------------------} +-- | Add a finalizer to a 'Ref'. +-- +-- See 'System.Mem.Weak.addFinalizer'. +addFinalizer :: Ref v -> IO () -> IO () +addFinalizer (Ref _ r _) = void . mkWeakIORef r () . Just + +-- | Weak pointer to a 'Ref'. +type WeakRef v = Weak.Weak (Ref v) + +-- | Create a weak pointer that associates a key with a value. +-- +-- See 'System.Mem.Weak.mkWeak'. +mkWeak + :: Ref k -- ^ key + -> v -- ^ value + -> Maybe (IO ()) -- ^ finalizer + -> IO (Weak.Weak v) +mkWeak (Ref _ r _) = mkWeakIORef r + +-- | Finalize a 'WeakRef'. +-- +-- See 'System.Mem.Weak.finalize'. +finalize :: WeakRef v -> IO () +finalize = Weak.finalize + +-- | Dereference a 'WeakRef'. +-- +-- See 'System.Mem.Weak.deRefWeak'. +deRefWeak :: Weak.Weak v -> IO (Maybe v) +deRefWeak = Weak.deRefWeak + +-- | Dereference a list of weak pointers while discarding dead ones. +deRefWeaks :: [Weak.Weak v] -> IO [v] +deRefWeaks ws = catMaybes <$> mapM Weak.deRefWeak ws + +{----------------------------------------------------------------------------- + Helpers +------------------------------------------------------------------------------} +-- | Create a weak pointer to an 'IORef'. +-- +-- Unpacking the constructors (e.g. 'GHC.IORef' etc.) is necessary +-- because the constructors may be unpacked while the 'IORef' is used +-- — so, the value contained therein is alive, but the constructors are not. +mkWeakIORef + :: IORef k -- ^ key + -> v -- ^ value + -> Maybe (IO ()) -- ^ finalizer + -> IO (Weak.Weak v) +mkWeakIORef (GHC.IORef (GHC.STRef r#)) v (Just (GHC.IO finalizer)) = + GHC.IO $ \s -> case GHC.mkWeak# r# v finalizer s of + (# s1, w #) -> (# s1, GHC.Weak w #) +mkWeakIORef (GHC.IORef (GHC.STRef r#)) v Nothing = + GHC.IO $ \s -> case GHC.mkWeakNoFinalizer# r# v s of + (# s1, w #) -> (# s1, GHC.Weak w #) diff --git a/src/Reactive/Banana/Prim/Mid.hs b/src/Reactive/Banana/Prim/Mid.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid.hs @@ -0,0 +1,116 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid ( + -- * Synopsis + -- | This is an internal module, useful if you want to + -- implemented your own FRP library. + -- If you just want to use FRP in your project, + -- have a look at "Reactive.Banana" instead. + + -- * Evaluation + Step, EvalNetwork, Network, emptyNetwork, getSize, + + -- * Build FRP networks + Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile, + module Control.Monad.IO.Class, + + -- * Caching + module Reactive.Banana.Prim.High.Cached, + + -- * Testing + interpret, mapAccumM, mapAccumM_, runSpaceProfile, + + -- * IO + newInput, addHandler, readLatch, + + -- * Pulse + Pulse, + neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP, + + -- * Latch + Latch, + pureL, mapL, applyL, accumL, applyP, + + -- * Dynamic event switching + switchL, executeP, switchP, + + -- * Notes + -- $recursion + + -- * Debugging + printDot + ) where + + +import Control.Monad.IO.Class +import Reactive.Banana.Prim.Mid.Combinators +import Reactive.Banana.Prim.Mid.Compile +import Reactive.Banana.Prim.Mid.IO +import Reactive.Banana.Prim.Mid.Plumbing + ( neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater ) +import Reactive.Banana.Prim.Mid.Types +import Reactive.Banana.Prim.High.Cached + +{----------------------------------------------------------------------------- + Notes +------------------------------------------------------------------------------} +-- Note [Recursion] +{- $recursion + +The 'Build' monad is an instance of 'MonadFix' and supports value recursion. +However, it is built on top of the 'IO' monad, so the recursion is +somewhat limited. + +The main rule for value recursion in the 'IO' monad is that the action +to be performed must be known in advance. For instance, the following snippet +will not work, because 'putStrLn' cannot complete its action without +inspecting @x@, which is not defined until later. + +> mdo +> putStrLn x +> let x = "Hello recursion" + +On the other hand, whenever the sequence of 'IO' actions can be known +before inspecting any later arguments, the recursion works. +For instance the snippet + +> mdo +> p1 <- mapP p2 +> p2 <- neverP +> return p1 + +works because 'mapP' does not inspect its argument. In other words, +a call @p1 <- mapP undefined@ would perform the same sequence of 'IO' actions. +(Internally, it essentially calls 'newIORef'.) + +With this issue in mind, almost all operations that build 'Latch' +and 'Pulse' values have been carefully implemented to not inspect +their arguments. +In conjunction with the 'Cached' mechanism for observable sharing, +this allows us to build combinators that can be used recursively. +One notable exception is the 'readLatch' function, which must +inspect its argument in order to be able to read its value. + +-} + +-- Note [LatchStrictness] +{- + +Any value that is stored in the graph over a longer +period of time must be stored in WHNF. + +This implies that the values in a latch must be forced to WHNF +when storing them. That doesn't have to be immediately +since we are tying a knot, but it definitely has to be done +before evaluateGraph is done. + +It also implies that reading a value from a latch must +be forced to WHNF before storing it again, so that we don't +carry around the old collection of latch values. +This is particularly relevant for `applyL`. + +Conversely, since latches are the only way to store values over time, +this is enough to guarantee that there are no space leaks in this regard. + +-} diff --git a/src/Reactive/Banana/Prim/Mid/Combinators.hs b/src/Reactive/Banana/Prim/Mid/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Combinators.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Combinators where + +import Control.Monad + ( join ) +import Control.Monad.IO.Class + ( liftIO ) + +import Reactive.Banana.Prim.Mid.Plumbing + ( newPulse, newLatch, cachedLatch + , dependOn, keepAlive, changeParent + , getValueL + , readPulseP, readLatchP, readLatchFutureP, liftBuildP, + ) +import qualified Reactive.Banana.Prim.Mid.Plumbing + ( pureL ) +import Reactive.Banana.Prim.Mid.Types + ( Latch, Future, Pulse, Build, EvalP ) + +debug :: String -> a -> a +-- debug s = trace s +debug _ = id + +{----------------------------------------------------------------------------- + Combinators - basic +------------------------------------------------------------------------------} +mapP :: (a -> b) -> Pulse a -> Build (Pulse b) +mapP f p1 = do + p2 <- newPulse "mapP" ({-# SCC mapP #-} fmap f <$> readPulseP p1) + p2 `dependOn` p1 + return p2 + +-- | Tag a 'Pulse' with future values of a 'Latch'. +-- +-- This is in contrast to 'applyP' which applies the current value +-- of a 'Latch' to a pulse. +tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a)) +tagFuture x p1 = do + p2 <- newPulse "tagFuture" $ + fmap . const <$> readLatchFutureP x <*> readPulseP p1 + p2 `dependOn` p1 + return p2 + +filterJustP :: Pulse (Maybe a) -> Build (Pulse a) +filterJustP p1 = do + p2 <- newPulse "filterJustP" ({-# SCC filterJustP #-} join <$> readPulseP p1) + p2 `dependOn` p1 + return p2 + +unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b) +unsafeMapIOP f p1 = do + p2 <- newPulse "unsafeMapIOP" + ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1) + p2 `dependOn` p1 + return p2 + where + eval :: Maybe a -> EvalP (Maybe b) + eval (Just x) = Just <$> liftIO (f x) + eval Nothing = return Nothing + +mergeWithP + :: (a -> Maybe c) + -> (b -> Maybe c) + -> (a -> b -> Maybe c) + -> Pulse a + -> Pulse b + -> Build (Pulse c) +mergeWithP f g h px py = do + p <- newPulse "mergeWithP" + ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py) + p `dependOn` px + p `dependOn` py + return p + where + eval Nothing Nothing = Nothing + eval (Just x) Nothing = f x + eval Nothing (Just y) = g y + eval (Just x) (Just y) = h x y + +-- See note [LatchRecursion] +applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) +applyP f x = do + p <- newPulse "applyP" + ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x) + p `dependOn` x + return p + +pureL :: a -> Latch a +pureL = Reactive.Banana.Prim.Mid.Plumbing.pureL + +-- specialization of mapL f = applyL (pureL f) +mapL :: (a -> b) -> Latch a -> Latch b +mapL f lx = cachedLatch ({-# SCC mapL #-} f <$> getValueL lx) + +applyL :: Latch (a -> b) -> Latch a -> Latch b +applyL lf lx = cachedLatch + ({-# SCC applyL #-} getValueL lf <*> getValueL lx) + +accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) +accumL a p1 = do + (updateOn, x) <- newLatch a + p2 <- newPulse "accumL" $ do + a <- readLatchP x + f <- readPulseP p1 + return $ fmap (\g -> g a) f + p2 `dependOn` p1 + updateOn p2 + return (x,p2) + +-- specialization of accumL +stepperL :: a -> Pulse a -> Build (Latch a) +stepperL a p = do + (updateOn, x) <- newLatch a + updateOn p + return x + +{----------------------------------------------------------------------------- + Combinators - dynamic event switching +------------------------------------------------------------------------------} +switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a) +switchL l pl = mdo + x <- stepperL l pl + return $ cachedLatch $ getValueL x >>= getValueL + +executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a) +executeP p1 b = do + p2 <- newPulse "executeP" ({-# SCC executeP #-} eval =<< readPulseP p1) + p2 `dependOn` p1 + return p2 + where + eval :: Maybe (b -> Build a) -> EvalP (Maybe a) + eval (Just x) = Just <$> liftBuildP (x b) + eval Nothing = return Nothing + +switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a) +switchP p pp = do + -- track the latest Pulse in a Latch + lp <- stepperL p pp + + -- fetch the latest Pulse value + pout <- newPulse "switchP_out" (readPulseP =<< readLatchP lp) + + let -- switch the Pulse `pout` to a new parent, + -- keeping track of the new dependencies. + switch = do + mnew <- readPulseP pp + case mnew of + Nothing -> pure () + Just new -> liftBuildP $ pout `changeParent` new + pure Nothing + + pin <- newPulse "switchP_in" switch :: Build (Pulse ()) + pin `dependOn` pp + + pout `dependOn` p -- initial dependency + pout `keepAlive` pin -- keep switches happening + pure pout diff --git a/src/Reactive/Banana/Prim/Mid/Compile.hs b/src/Reactive/Banana/Prim/Mid/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Compile.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Compile where + +import Control.Exception + ( evaluate ) +import Data.Functor + ( void ) +import Data.IORef + ( newIORef, readIORef, writeIORef ) + +import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC +import qualified Reactive.Banana.Prim.Low.OrderedBag as OB +import Reactive.Banana.Prim.Mid.Combinators (mapP) +import Reactive.Banana.Prim.Mid.Evaluation (applyDependencyChanges) +import Reactive.Banana.Prim.Mid.IO +import Reactive.Banana.Prim.Mid.Plumbing +import Reactive.Banana.Prim.Mid.Types + +{----------------------------------------------------------------------------- + Compilation +------------------------------------------------------------------------------} +-- | Change a 'Network' of pulses and latches by +-- executing a 'BuildIO' action. +compile :: BuildIO a -> Network -> IO (a, Network) +compile m Network{nTime, nOutputs, nAlwaysP, nGraphGC} = do + (a, dependencyChanges, os) <- runBuildIO (nTime, nAlwaysP) m + + applyDependencyChanges dependencyChanges nGraphGC + let state2 = Network + { nTime = next nTime + , nOutputs = OB.inserts nOutputs os + , nAlwaysP + , nGraphGC + } + return (a,state2) + +emptyNetwork :: IO Network +emptyNetwork = do + (alwaysP, _, _) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ()) + nGraphGC <- GraphGC.new + pure Network + { nTime = next beginning + , nOutputs = OB.empty + , nAlwaysP = alwaysP + , nGraphGC + } + +{----------------------------------------------------------------------------- + Testing +------------------------------------------------------------------------------} +-- | Simple interpreter for pulse/latch networks. +-- +-- Mainly useful for testing functionality +-- +-- Note: The result is not computed lazily, for similar reasons +-- that the 'sequence' function does not compute its result lazily. +interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b] +interpret f xs = do + o <- newIORef Nothing + let network = do + (pin, sin) <- liftBuild newInput + pmid <- f pin + pout <- liftBuild $ mapP return pmid + liftBuild $ addHandler pout (writeIORef o . Just) + return sin + + -- compile initial network + (sin, state) <- compile network =<< emptyNetwork + + let go Nothing s1 = return (Nothing,s1) + go (Just a) s1 = do + (reactimate,s2) <- sin a s1 + reactimate -- write output + ma <- readIORef o -- read output + writeIORef o Nothing + return (ma,s2) + + fst <$> mapAccumM go state xs -- run several steps + +-- | Execute an FRP network with a sequence of inputs. +-- Make sure that outputs are evaluated, but don't display their values. +-- +-- Mainly useful for testing whether there are space leaks. +runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO () +runSpaceProfile f xs = do + let g = do + (p1, fire) <- liftBuild newInput + p2 <- f p1 + p3 <- mapP return p2 -- wrap into Future + addHandler p3 (void . evaluate) + return fire + (step,network) <- compile g =<< emptyNetwork + + let fire x s1 = do + (outputs, s2) <- step x s1 + outputs -- don't forget to execute outputs + return ((), s2) + + mapAccumM_ fire network xs + +-- | 'mapAccum' for a monad. +mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ([b],s) +mapAccumM f s0 = go s0 [] + where + go s1 bs [] = pure (reverse bs,s1) + go s1 bs (x:xs) = do + (b,s2) <- f x s1 + go s2 (b:bs) xs + +-- | Strict 'mapAccum' for a monad. Discards results. +mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m () +mapAccumM_ _ _ [] = return () +mapAccumM_ f !s0 (x:xs) = do + (_,s1) <- f x s0 + mapAccumM_ f s1 xs diff --git a/src/Reactive/Banana/Prim/Mid/Evaluation.hs b/src/Reactive/Banana/Prim/Mid/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Evaluation.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Evaluation + ( step + , applyDependencyChanges + ) where + +import Control.Monad + ( join ) +import Control.Monad.IO.Class + ( liftIO ) + +import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC +import qualified Reactive.Banana.Prim.Low.OrderedBag as OB +import qualified Reactive.Banana.Prim.Low.Ref as Ref +import Reactive.Banana.Prim.Mid.Plumbing +import Reactive.Banana.Prim.Mid.Types + +{----------------------------------------------------------------------------- + Evaluation step +------------------------------------------------------------------------------} +-- | Evaluate all the pulses in the graph, +-- Rebuild the graph as necessary and update the latch values. +step :: Inputs -> Step +step (inputs,pulses) + Network{ nTime = time1 + , nOutputs = outputs1 + , nAlwaysP = alwaysP + , nGraphGC + } + = do + + -- evaluate pulses + ((_, (latchUpdates, outputs)), dependencyChanges, os) + <- runBuildIO (time1, alwaysP) + $ runEvalP pulses + $ evaluatePulses inputs nGraphGC + + doit latchUpdates -- update latch values from pulses + applyDependencyChanges dependencyChanges -- rearrange graph topology + nGraphGC + GraphGC.removeGarbage nGraphGC -- remove unreachable pulses + let actions :: [(Output, EvalO)] + actions = OB.inOrder outputs outputs1 -- EvalO actions in proper order + + state2 :: Network + !state2 = Network + { nTime = next time1 + , nOutputs = OB.inserts outputs1 os + , nAlwaysP = alwaysP + , nGraphGC + } + return (runEvalOs $ map snd actions, state2) + +runEvalOs :: [EvalO] -> IO () +runEvalOs = mapM_ join + +{----------------------------------------------------------------------------- + Dependency changes +------------------------------------------------------------------------------} +-- | Apply all dependency changes to the 'GraphGC'. +applyDependencyChanges :: DependencyChanges -> Dependencies -> IO () +applyDependencyChanges changes g = do + sequence_ [applyDependencyChange c g | c@(InsertEdge _ _) <- changes] + sequence_ [applyDependencyChange c g | c@(ChangeParentTo _ _) <- changes] + +applyDependencyChange + :: DependencyChange SomeNode SomeNode -> Dependencies -> IO () +applyDependencyChange (InsertEdge parent child) g = + GraphGC.insertEdge (parent, child) g +applyDependencyChange (ChangeParentTo child parent) g = do + GraphGC.clearPredecessors child g + GraphGC.insertEdge (parent, child) g + +{----------------------------------------------------------------------------- + Traversal in dependency order +------------------------------------------------------------------------------} +-- | Update all pulses in the graph, starting from a given set of nodes +evaluatePulses :: [SomeNode] -> Dependencies -> EvalP () +evaluatePulses inputs g = do + action <- liftIO $ GraphGC.walkSuccessors_ inputs evaluateWeakNode g + action + +evaluateWeakNode :: Ref.WeakRef SomeNodeD -> EvalP GraphGC.Step +evaluateWeakNode w = do + mnode <- liftIO $ Ref.deRefWeak w + case mnode of + Nothing -> pure GraphGC.Stop + Just node -> evaluateNode node + +-- | Recalculate a given node and return all children nodes +-- that need to evaluated subsequently. +evaluateNode :: SomeNode -> EvalP GraphGC.Step +evaluateNode someNode = do + node <- Ref.read someNode + case node of + P PulseD{_evalP,_keyP} -> {-# SCC evaluateNodeP #-} do + ma <- _evalP + writePulseP _keyP ma + pure $ case ma of + Nothing -> GraphGC.Stop + Just _ -> GraphGC.Next + L lw -> {-# SCC evaluateLatchWrite #-} do + evaluateLatchWrite lw + pure GraphGC.Stop + O o -> {-# SCC evaluateNodeO #-} do + m <- _evalO o -- calculate output action + rememberOutput (someNode,m) + pure GraphGC.Stop + +evaluateLatchWrite :: LatchWriteD -> EvalP () +evaluateLatchWrite LatchWriteD{_evalLW,_latchLW} = do + time <- askTime + mlatch <- liftIO $ Ref.deRefWeak _latchLW -- retrieve destination latch + case mlatch of + Nothing -> pure () + Just latch -> do + a <- _evalLW -- calculate new latch value + -- liftIO $ Strict.evaluate a -- see Note [LatchStrictness] + rememberLatchUpdate $ -- schedule value to be set later + Ref.modify' latch $ \l -> + a `seq` l { _seenL = time, _valueL = a } diff --git a/src/Reactive/Banana/Prim/Mid/IO.hs b/src/Reactive/Banana/Prim/Mid/IO.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/IO.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.IO where + +import Control.Monad.IO.Class + ( liftIO ) +import qualified Data.Vault.Lazy as Lazy + +import Reactive.Banana.Prim.Mid.Combinators (mapP) +import Reactive.Banana.Prim.Mid.Evaluation (step) +import Reactive.Banana.Prim.Mid.Plumbing +import Reactive.Banana.Prim.Mid.Types +import qualified Reactive.Banana.Prim.Low.Ref as Ref + +debug :: String -> a -> a +debug _ = id + +{----------------------------------------------------------------------------- + Primitives connecting to the outside world +------------------------------------------------------------------------------} +-- | Create a new pulse in the network and a function to trigger it. +-- +-- Together with 'addHandler', this function can be used to operate with +-- pulses as with standard callback-based events. +newInput :: forall a. Build (Pulse a, a -> Step) +newInput = mdo + always <- alwaysP + _key <- liftIO Lazy.newKey + nodeP <- liftIO $ Ref.new $ P $ PulseD + { _keyP = _key + , _seenP = agesAgo + , _evalP = readPulseP pulse -- get its own value + , _nameP = "newInput" + } + let pulse = Pulse{_key,_nodeP=nodeP} + -- Also add the alwaysP pulse to the inputs. + let run :: a -> Step + run a = step ([nodeP, _nodeP always], Lazy.insert _key (Just a) Lazy.empty) + pure (pulse, run) + +-- | Register a handler to be executed whenever a pulse occurs. +-- +-- The pulse may refer to future latch values. +addHandler :: Pulse (Future a) -> (a -> IO ()) -> Build () +addHandler p1 f = do + p2 <- mapP (fmap f) p1 + addOutput p2 + +-- | Read the value of a 'Latch' at a particular moment in time. +readLatch :: Latch a -> Build a +readLatch = readLatchB diff --git a/src/Reactive/Banana/Prim/Mid/Plumbing.hs b/src/Reactive/Banana/Prim/Mid/Plumbing.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Plumbing.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Plumbing where + +import Control.Monad + ( join, void ) +import Control.Monad.IO.Class + ( liftIO ) +import Data.IORef + ( newIORef, writeIORef, readIORef ) +import Data.Maybe + ( fromMaybe ) +import System.IO.Unsafe + ( unsafePerformIO, unsafeInterleaveIO ) + +import qualified Control.Monad.Trans.RWSIO as RWS +import qualified Control.Monad.Trans.ReaderWriterIO as RW +import qualified Data.Vault.Lazy as Lazy + +import qualified Reactive.Banana.Prim.Low.Ref as Ref +import Reactive.Banana.Prim.Mid.Types + +{----------------------------------------------------------------------------- + Build primitive pulses and latches +------------------------------------------------------------------------------} +-- | Make 'Pulse' from evaluation function +newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a) +newPulse name eval = liftIO $ do + _key <- Lazy.newKey + _nodeP <- Ref.new $ P $ PulseD + { _keyP = _key + , _seenP = agesAgo + , _evalP = eval + , _nameP = name + } + pure $ Pulse{_key,_nodeP} + +{- +* Note [PulseCreation] + +We assume that we do not have to calculate a pulse occurrence +at the moment we create the pulse. Otherwise, we would have +to recalculate the dependencies *while* doing evaluation; +this is a recipe for desaster. + +-} + +-- | 'Pulse' that never fires. +neverP :: Build (Pulse a) +neverP = liftIO $ do + _key <- Lazy.newKey + _nodeP <- Ref.new $ P $ PulseD + { _keyP = _key + , _seenP = agesAgo + , _evalP = pure Nothing + , _nameP = "neverP" + } + pure $ Pulse{_key,_nodeP} + +-- | Return a 'Latch' that has a constant value +pureL :: a -> Latch a +pureL a = unsafePerformIO $ Ref.new $ Latch + { _seenL = beginning + , _valueL = a + , _evalL = return a + } + +-- | Make new 'Latch' that can be updated by a 'Pulse' +newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch a) +newLatch a = do + latch <- liftIO $ mdo + latch <- Ref.new $ Latch + { _seenL = beginning + , _valueL = a + , _evalL = do + Latch {..} <- Ref.read latch + RW.tell _seenL -- indicate timestamp + return _valueL -- indicate value + } + pure latch + + let + err = error "incorrect Latch write" + + updateOn :: Pulse a -> Build () + updateOn p = do + w <- liftIO $ Ref.mkWeak latch latch Nothing + lw <- liftIO $ Ref.new $ L $ LatchWriteD + { _evalLW = fromMaybe err <$> readPulseP p + , _latchLW = w + } + -- writer is alive only as long as the latch is alive + _ <- liftIO $ Ref.mkWeak latch lw Nothing + _nodeP p `addChild` lw + + return (updateOn, latch) + +-- | Make a new 'Latch' that caches a previous computation. +cachedLatch :: EvalL a -> Latch a +cachedLatch eval = unsafePerformIO $ mdo + latch <- Ref.new $ Latch + { _seenL = agesAgo + , _valueL = error "Undefined value of a cached latch." + , _evalL = do + Latch{..} <- liftIO $ Ref.read latch + -- calculate current value (lazy!) with timestamp + (a,time) <- RW.listen eval + liftIO $ if time <= _seenL + then return _valueL -- return old value + else do -- update value + let _seenL = time + let _valueL = a + a `seq` Ref.put latch (Latch {..}) + return a + } + return latch + +-- | Add a new output that depends on a 'Pulse'. +-- +-- TODO: Return function to unregister the output again. +addOutput :: Pulse EvalO -> Build () +addOutput p = do + o <- liftIO $ Ref.new $ O $ Output + { _evalO = fromMaybe (pure $ pure ()) <$> readPulseP p + } + _nodeP p `addChild` o + RW.tell $ BuildW (mempty, [o], mempty, mempty) + +{----------------------------------------------------------------------------- + Build monad +------------------------------------------------------------------------------} +runBuildIO :: BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output]) +runBuildIO i m = do + (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m + doit liftIOLaters -- execute late IOs + return (a,topologyUpdates,os) + where + -- Recursively execute the buildLater calls. + unfold :: BuildW -> BuildIO a -> IO (a, BuildW) + unfold w m = do + (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i + let w' = w <> BuildW (w1,w2,w3,mempty) + w'' <- case later of + Just m -> snd <$> unfold w' m + Nothing -> return w' + return (a,w'') + +buildLater :: Build () -> Build () +buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x) + +-- | Pretend to return a value right now, +-- but do not actually calculate it until later. +-- +-- NOTE: Accessing the value before it's written leads to an error. +-- +-- FIXME: Is there a way to have the value calculate on demand? +buildLaterReadNow :: Build a -> Build a +buildLaterReadNow m = do + ref <- liftIO $ newIORef $ + error "buildLaterReadNow: Trying to read before it is written." + buildLater $ m >>= liftIO . writeIORef ref + liftIO $ unsafeInterleaveIO $ readIORef ref + +liftBuild :: Build a -> BuildIO a +liftBuild = id + +getTimeB :: Build Time +getTimeB = fst <$> RW.ask + +alwaysP :: Build (Pulse ()) +alwaysP = snd <$> RW.ask + +readLatchB :: Latch a -> Build a +readLatchB = liftIO . readLatchIO + +dependOn :: Pulse child -> Pulse parent -> Build () +dependOn child parent = _nodeP parent `addChild` _nodeP child + +keepAlive :: Pulse child -> Pulse parent -> Build () +keepAlive child parent = liftIO $ void $ + Ref.mkWeak (_nodeP child) (_nodeP parent) Nothing + +addChild :: SomeNode -> SomeNode -> Build () +addChild parent child = + RW.tell $ BuildW ([InsertEdge parent child], mempty, mempty, mempty) + +changeParent :: Pulse child -> Pulse parent -> Build () +changeParent pulse0 parent0 = + RW.tell $ BuildW ([ChangeParentTo pulse parent], mempty, mempty, mempty) + where + pulse = _nodeP pulse0 + parent = _nodeP parent0 + +liftIOLater :: IO () -> Build () +liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty) + +{----------------------------------------------------------------------------- + EvalL monad +------------------------------------------------------------------------------} +-- | Evaluate a latch (-computation) at the latest time, +-- but discard timestamp information. +readLatchIO :: Latch a -> IO a +readLatchIO latch = do + Latch{..} <- Ref.read latch + liftIO $ fst <$> RW.runReaderWriterIOT _evalL () + +getValueL :: Latch a -> EvalL a +getValueL latch = do + Latch{..} <- Ref.read latch + _evalL + +{----------------------------------------------------------------------------- + EvalP monad +------------------------------------------------------------------------------} +runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW) +runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do + (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1 + return ((a,w1), w2) + +liftBuildP :: Build a -> EvalP a +liftBuildP m = RWS.rwsT $ \r2 s -> do + (a,w2) <- RW.runReaderWriterIOT m r2 + return (a,s,(mempty,w2)) + +askTime :: EvalP Time +askTime = fst <$> RWS.ask + +readPulseP :: Pulse a -> EvalP (Maybe a) +readPulseP Pulse{_key} = + join . Lazy.lookup _key <$> RWS.get + +writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP () +writePulseP key a = do + s <- RWS.get + RWS.put $ Lazy.insert key a s + +readLatchP :: Latch a -> EvalP a +readLatchP = liftBuildP . readLatchB + +readLatchFutureP :: Latch a -> EvalP (Future a) +readLatchFutureP = return . readLatchIO + +rememberLatchUpdate :: IO () -> EvalP () +rememberLatchUpdate x = RWS.tell ((Action x,mempty),mempty) + +rememberOutput :: (Output, EvalO) -> EvalP () +rememberOutput x = RWS.tell ((mempty,[x]),mempty) + +-- worker wrapper to break sharing and support better inlining +unwrapEvalP :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a +unwrapEvalP r m = RWS.run m r + +wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a +wrapEvalP m = RWS.R m diff --git a/src/Reactive/Banana/Prim/Mid/Test.hs b/src/Reactive/Banana/Prim/Mid/Test.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Test.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecursiveDo #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Test where + +import Reactive.Banana.Prim.Mid + +main :: IO () +main = test_space1 + +{----------------------------------------------------------------------------- + Functionality tests +------------------------------------------------------------------------------} +test_accumL1 :: Pulse Int -> BuildIO (Pulse Int) +test_accumL1 p1 = liftBuild $ do + p2 <- mapP (+) p1 + (l1,_) <- accumL 0 p2 + let l2 = mapL const l1 + applyP l2 p1 + +test_recursion1 :: Pulse () -> BuildIO (Pulse Int) +test_recursion1 p1 = liftBuild $ mdo + p2 <- applyP l2 p1 + p3 <- mapP (const (+1)) p2 + ~(l1,_) <- accumL (0::Int) p3 + let l2 = mapL const l1 + return p2 + +-- test garbage collection + +{----------------------------------------------------------------------------- + Space leak tests +------------------------------------------------------------------------------} +test_space1 :: IO () +test_space1 = runSpaceProfile test_accumL1 [1::Int .. 2 * 10 ^ (4 :: Int)] + +test_space2 :: IO () +test_space2 = runSpaceProfile test_recursion1 $ () <$ [1::Int .. 2 * 10 ^ (4 :: Int)] diff --git a/src/Reactive/Banana/Prim/Mid/Types.hs b/src/Reactive/Banana/Prim/Mid/Types.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Mid/Types.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Mid.Types where + +import Data.Hashable + ( hashWithSalt ) +import Data.Unique.Really + ( Unique ) +import Control.Monad.Trans.RWSIO + ( RWSIOT ) +import Control.Monad.Trans.ReaderWriterIO + ( ReaderWriterIOT ) +import Reactive.Banana.Prim.Low.OrderedBag + ( OrderedBag ) +import System.IO.Unsafe + ( unsafePerformIO ) +import System.Mem.Weak + ( Weak ) + +import qualified Data.Vault.Lazy as Lazy +import qualified Reactive.Banana.Prim.Low.Ref as Ref +import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC + +{----------------------------------------------------------------------------- + Network +------------------------------------------------------------------------------} +-- | A 'Network' represents the state of a pulse/latch network, +data Network = Network + { nTime :: !Time -- Current time. + , nOutputs :: !(OrderedBag Output) -- Remember outputs to prevent garbage collection. + , nAlwaysP :: !(Pulse ()) -- Pulse that always fires. + , nGraphGC :: Dependencies + } + +getSize :: Network -> IO Int +getSize = GraphGC.getSize . nGraphGC + +type Dependencies = GraphGC.GraphGC SomeNodeD +type Inputs = ([SomeNode], Lazy.Vault) +type EvalNetwork a = Network -> IO (a, Network) +type Step = EvalNetwork (IO ()) + +type Build = ReaderWriterIOT BuildR BuildW IO +type BuildR = (Time, Pulse ()) + -- ( current time + -- , pulse that always fires) +newtype BuildW = BuildW (DependencyChanges, [Output], Action, Maybe (Build ())) + -- reader : current timestamp + -- writer : ( actions that change the network topology + -- , outputs to be added to the network + -- , late IO actions + -- , late build actions + -- ) + +instance Semigroup BuildW where + BuildW x <> BuildW y = BuildW (x <> y) + +instance Monoid BuildW where + mempty = BuildW mempty + mappend = (<>) + +type BuildIO = Build + +data DependencyChange parent child + = InsertEdge parent child + | ChangeParentTo child parent +type DependencyChanges = [DependencyChange SomeNode SomeNode] + +{----------------------------------------------------------------------------- + Synonyms +------------------------------------------------------------------------------} +-- | 'IO' actions as a monoid with respect to sequencing. +newtype Action = Action { doit :: IO () } +instance Semigroup Action where + Action x <> Action y = Action (x >> y) +instance Monoid Action where + mempty = Action $ return () + mappend = (<>) + +{----------------------------------------------------------------------------- + Pulse and Latch +------------------------------------------------------------------------------} +data Pulse a = Pulse + { _key :: Lazy.Key (Maybe a) -- Key to retrieve pulse value from cache. + , _nodeP :: SomeNode -- Reference to its own node + } + +data PulseD a = PulseD + { _keyP :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache. + , _seenP :: !Time -- See note [Timestamp]. + , _evalP :: EvalP (Maybe a) -- Calculate current value. + , _nameP :: String -- Name for debugging. + } + +instance Show (Pulse a) where + show p = name <> " " <> show (hashWithSalt 0 $ _nodeP p) + where + name = case unsafePerformIO $ Ref.read $ _nodeP p of + P pulseD -> _nameP pulseD + _ -> "" + +showUnique :: Unique -> String +showUnique = show . hashWithSalt 0 + +type Latch a = Ref.Ref (LatchD a) +data LatchD a = Latch + { _seenL :: !Time -- Timestamp for the current value. + , _valueL :: a -- Current value. + , _evalL :: EvalL a -- Recalculate current latch value. + } + +type LatchWrite = SomeNode +data LatchWriteD = forall a. LatchWriteD + { _evalLW :: EvalP a -- Calculate value to write. + , _latchLW :: Weak (Latch a) -- Destination 'Latch' to write to. + } + +type Output = SomeNode +data OutputD = Output + { _evalO :: EvalP EvalO + } + +type SomeNode = Ref.Ref SomeNodeD +data SomeNodeD + = forall a. P (PulseD a) + | L LatchWriteD + | O OutputD + +{-# INLINE mkWeakNodeValue #-} +mkWeakNodeValue :: SomeNode -> v -> IO (Weak v) +mkWeakNodeValue x v = Ref.mkWeak x v Nothing + +-- | Evaluation monads. +type EvalPW = (EvalLW, [(Output, EvalO)]) +type EvalLW = Action + +type EvalO = Future (IO ()) +type Future = IO + +-- Note: For efficiency reasons, we unroll the monad transformer stack. +-- type EvalP = RWST () Lazy.Vault EvalPW Build +type EvalP = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO + -- writer : (latch updates, IO action) + -- state : current pulse values + +-- Computation with a timestamp that indicates the last time it was performed. +type EvalL = ReaderWriterIOT () Time IO + +{----------------------------------------------------------------------------- + Show functions for debugging +------------------------------------------------------------------------------} +printNode :: SomeNode -> IO String +printNode node = do + someNode <- Ref.read node + pure $ case someNode of + P p -> _nameP p + L _ -> "L" + O _ -> "O" + +-- | Show the graph of the 'Network' in @graphviz@ dot file format. +printDot :: Network -> IO String +printDot = GraphGC.printDot format . nGraphGC + where + format u weakref = do + mnode <- Ref.deRefWeak weakref + ((showUnique u <> ": ") <>) <$> case mnode of + Nothing -> pure "(x_x)" + Just node -> printNode node + +{----------------------------------------------------------------------------- + Time monoid +------------------------------------------------------------------------------} +-- | A timestamp local to this program run. +-- +-- Useful e.g. for controlling cache validity. +newtype Time = T Integer deriving (Eq, Ord, Show, Read) + +-- | Before the beginning of time. See Note [TimeStamp] +agesAgo :: Time +agesAgo = T (-1) + +beginning :: Time +beginning = T 0 + +next :: Time -> Time +next (T n) = T (n+1) + +instance Semigroup Time where + T x <> T y = T (max x y) + +instance Monoid Time where + mappend = (<>) + mempty = beginning + +{----------------------------------------------------------------------------- + Notes +------------------------------------------------------------------------------} +{- Note [Timestamp] + +The time stamp indicates how recent the current value is. + +For Pulse: +During pulse evaluation, a time stamp equal to the current +time indicates that the pulse has already been evaluated in this phase. + +For Latch: +The timestamp indicates the last time at which the latch has been written to. + + agesAgo = The latch has never been written to. + beginning = The latch has been written to before everything starts. + +The second description is ensured by the fact that the network +writes timestamps that begin at time `next beginning`. + +-} diff --git a/src/Reactive/Banana/Prim/Order.hs b/src/Reactive/Banana/Prim/Order.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Order.hs +++ /dev/null @@ -1,90 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE Rank2Types, BangPatterns, RecordWildCards #-} -module Reactive.Banana.Prim.Order ( - -- * Synopsis - -- | Data structure that represents a partial ordering by levels. - - -- * Order - Order, flat, - ensureAbove, recalculateParent, - Level, level, - - ) where - -import Data.Functor -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Hashable -import qualified Data.IntMap.Strict as IntMap - -type IntMap = IntMap.IntMap -type Map = Map.HashMap -type Set = Set.HashSet - -{----------------------------------------------------------------------------- - Order by levels -------------------------------------------------------------------------------} --- | Each element is assigned a /level/. --- Elements in lower levels come before elements in higher levels. --- There is no order on elements within the same level. -type Order a = Map a Level - --- | FIXME: Level should be an 'Integer' to avoid overflow. --- --- FIXME: The algorithms in this module currently do not try to --- shrink the number or width of levels. -type Level = Integer - --- | The flat order where every element is at 'ground' level. -flat :: Order a -flat = Map.empty - --- | Ground level. -ground :: Level -ground = 0 - --- | Look up the level of an element. Default level is 'ground'. -level :: (Eq a, Hashable a) => a -> Order a -> Level -level x = {-# SCC level #-} maybe ground id . Map.lookup x - --- | Make sure that the first argument is at least one level --- above the second argument. -ensureAbove :: (Eq a, Hashable a) => a -> a -> Order a -> Order a -ensureAbove child parent order = - Map.insertWith max child (level parent order + 1) order - --- | Reassign the parent for a child and recalculate the levels --- for the new parents and grandparents. -recalculateParent :: (Eq a, Hashable a) - => a -- Child. - -> a -- Parent. - -> Graph a -- Query parents of a node. - -> Order a -> Order a -recalculateParent child parent parents order - | d <= 0 = order - | otherwise = concatenate - [ Map.insertWith (+) node (-d) | node <- dfs parent parents ] - order - where - d = level parent order - level child order + 1 - -- level parent - d = level child - 1 - concatenate = foldr (.) id - -{----------------------------------------------------------------------------- - Graph traversal -------------------------------------------------------------------------------} --- | Graph represented as map of successors. -type Graph a = a -> [a] - --- | Depth-first search. List all transitive successors of a node. -dfs :: (Eq a, Hashable a) => a -> Graph a -> [a] -dfs x succs = go [x] Set.empty - where - go [] _ = [] - go (x:xs) seen - | x `Set.member` seen = go xs seen - | otherwise = x : go (ys ++ xs) (Set.insert x seen) - where - ys = succs x diff --git a/src/Reactive/Banana/Prim/Plumbing.hs b/src/Reactive/Banana/Prim/Plumbing.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Plumbing.hs +++ /dev/null @@ -1,163 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Reactive.Banana.Prim.Plumbing where - -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS -import qualified Control.Monad.Trans.State as State -import Data.Function -import Data.Functor -import Data.Functor.Identity -import Data.List -import Data.Monoid -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) - -import Reactive.Banana.Prim.Cached (HasCache(..)) -import qualified Reactive.Banana.Prim.Dated as Dated -import qualified Reactive.Banana.Prim.Dependencies as Deps -import Reactive.Banana.Prim.Types - -{----------------------------------------------------------------------------- - Build primitive pulses and latches -------------------------------------------------------------------------------} --- | Make 'Pulse' from evaluation function -newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a) -newPulse name eval = unsafePerformIO $ do - key <- Lazy.newKey - uid <- newUnique - return $ do - let write = maybe (return Deps.Done) ((Deps.Children <$) . writePulseP key) - return $ Pulse - { evaluateP = {-# SCC evaluateP #-} write =<< eval - , getValueP = Lazy.lookup key - , uidP = uid - , nameP = name - } - --- | 'Pulse' that never fires. -neverP :: Build (Pulse a) -neverP = unsafePerformIO $ do - uid <- newUnique - return $ return $ Pulse - { evaluateP = return Deps.Done - , getValueP = const Nothing - , uidP = uid - , nameP = "neverP" - } - --- | Make new 'Latch' that can be updated. -newLatch :: a -> Build (Pulse a -> Build (), Latch a) -newLatch a = unsafePerformIO $ do - key <- Dated.newKey - uid <- newUnique - return $ do - let - write time = maybe mempty (Endo . Dated.update' key time) - latchWrite p = LatchWrite - { evaluateL = {-# SCC evaluateL #-} do - time <- lift $ nTime <$> get - write (Dated.next time) <$> readPulseP p - , uidL = uid - } - updateOn p = P p `addChild` L (latchWrite p) - return - (updateOn, Latch { getValueL = Dated.findWithDefault a key }) - --- | Make a new 'Latch' that caches a previous computation -cachedLatch :: Dated.Dated (Dated.Box a) -> Latch a -cachedLatch eval = unsafePerformIO $ do - key <- Dated.newKey - return $ Latch { getValueL = {-# SCC getValueL #-} Dated.cache key eval } - --- | Add a new output that depends on a 'Pulse'. --- --- TODO: Return function to unregister the output again. -addOutput :: Pulse EvalO -> Build () -addOutput p = unsafePerformIO $ do - uid <- newUnique - return $ do - pos <- grOutputCount . nGraph <$> get - let o = Output - { evaluateO = {-# SCC evaluateO #-} maybe nop id <$> readPulseP p - , uidO = uid - , positionO = pos - } - modify $ updateGraph $ updateOutputCount $ (+1) - P p `addChild` O o - -{----------------------------------------------------------------------------- - Build monad - add and delete nodes from the graph -------------------------------------------------------------------------------} -runBuildIO :: Network -> BuildIO a -> IO (a, Network) -runBuildIO s1 m = {-# SCC runBuildIO #-} do - (a,s2,liftIOLaters) <- runRWST m () s1 - sequence_ liftIOLaters -- execute late IOs - return (a,s2) - --- Lift a pure Build computation into any monad. --- See note [BuildT] -liftBuild :: Monad m => Build a -> BuildT m a -liftBuild m = RWST $ \r s -> return . runIdentity $ runRWST m r s - -readLatchB :: Latch a -> Build a -readLatchB latch = state $ \network -> - let (a,v) = Dated.runDated (getValueL latch) (nLatchValues network) - in (Dated.unBox a, network { nLatchValues = v } ) - -alwaysP :: Build (Pulse ()) -alwaysP = grAlwaysP . nGraph <$> get - -instance (MonadFix m, Functor m) => HasCache (BuildT m) where - retrieve key = Lazy.lookup key . grCache . nGraph <$> get - write key a = modify $ updateGraph $ updateCache $ Lazy.insert key a - -dependOn :: Pulse child -> Pulse parent -> Build () -dependOn child parent = (P parent) `addChild` (P child) - -changeParent :: Pulse child -> Pulse parent -> Build () -changeParent child parent = - modify . updateGraph . updateDeps $ Deps.changeParent (P child) (P parent) - -addChild :: SomeNode -> SomeNode -> Build () -addChild parent child = - modify . updateGraph . updateDeps $ Deps.addChild parent child - -liftIOLater :: IO () -> Build () -liftIOLater x = tell [x] - -{----------------------------------------------------------------------------- - EvalP - evaluate pulses -------------------------------------------------------------------------------} -runEvalP :: Lazy.Vault -> EvalP (EvalL, [(Position, EvalO)]) - -> BuildIO (Lazy.Vault, EvalL, EvalO) -runEvalP pulse m = do - ((wl,wo),s) <- State.runStateT m pulse - return (s,wl, sequence_ <$> sequence (sortOutputs wo)) - where - sortOutputs = map snd . sortBy (compare `on` fst) - -readLatchP :: Latch a -> EvalP a -readLatchP = {-# SCC readLatchP #-} lift . liftBuild . readLatchB - -readLatchFutureP :: Latch a -> EvalP (Future a) -readLatchFutureP latch = State.state $ \s -> (Dated.unBox <$> getValueL latch,s) - -writePulseP :: Lazy.Key a -> a -> EvalP () -writePulseP key a = {-# SCC writePulseP #-} State.modify $ Lazy.insert key a - -readPulseP :: Pulse a -> EvalP (Maybe a) -readPulseP pulse = {-# SCC readPulseP #-} getValueP pulse <$> State.get - -liftBuildIOP :: BuildIO a -> EvalP a -liftBuildIOP = lift - -liftBuildP :: Build a -> EvalP a -liftBuildP = liftBuildIOP . liftBuild - - diff --git a/src/Reactive/Banana/Prim/Test.hs b/src/Reactive/Banana/Prim/Test.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Test.hs +++ /dev/null @@ -1,37 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo #-} -module Reactive.Banana.Prim.Test where - -import Control.Applicative -import Reactive.Banana.Prim - -main = test_space1 - -{----------------------------------------------------------------------------- - Functionality tests -------------------------------------------------------------------------------} -test_accumL1 :: Pulse Int -> BuildIO (Pulse Int) -test_accumL1 p1 = liftBuild $ do - p2 <- mapP (+) p1 - (l1,_) <- accumL 0 p2 - let l2 = mapL const l1 - p3 <- applyP l2 p1 - return p3 - -test_recursion1 :: Pulse () -> BuildIO (Pulse Int) -test_recursion1 p1 = liftBuild $ mdo - p2 <- applyP l2 p1 - p3 <- mapP (const (+1)) p2 - ~(l1,_) <- accumL (0::Int) p3 - let l2 = mapL const l1 - return p2 - -{----------------------------------------------------------------------------- - Space leak tests -------------------------------------------------------------------------------} -test_space1 = runSpaceProfile test_accumL1 $ [1..2*10^4] -test_space2 = runSpaceProfile test_recursion1 $ () <$ [1..2*10^4] - - diff --git a/src/Reactive/Banana/Prim/Types.hs b/src/Reactive/Banana/Prim/Types.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Types.hs +++ /dev/null @@ -1,194 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE ExistentialQuantification #-} -module Reactive.Banana.Prim.Types where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS.Lazy -import Control.Monad.Trans.State -import Data.Functor.Identity -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Hashable -import Data.Monoid -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) - -import Reactive.Banana.Prim.Cached -import qualified Reactive.Banana.Prim.Dated as Dated -import qualified Reactive.Banana.Prim.Dependencies as Deps - -type Deps = Deps.Deps - -{----------------------------------------------------------------------------- - Graph -------------------------------------------------------------------------------} --- | A 'Graph' represents the connections between pulses and events. -data Graph = Graph - { grDeps :: Deps SomeNode -- dependency information - , grCache :: Lazy.Vault -- cache for the monad - , grAlwaysP :: Pulse () -- special pulse that always fires - , grOutputCount :: !Position -- ensure declaration order - } -type Position = Integer - -instance Show Graph where show = showDeps . grDeps - --- | A 'Network' represents the state of a pulse/latch network, --- which consists of a 'Graph' and the values of all accumulated latches --- in the network. -data Network = Network - { nGraph :: Graph - , nLatchValues :: Dated.Vault - , nTime :: Dated.Time - } - -instance Show Network where show = show . nGraph - -type Inputs = (Lazy.Vault, [SomeNode]) -type EvalNetwork a = Network -> IO (a, Network) -type Step = EvalNetwork (IO ()) - --- | Lenses for the 'Graph' and the 'Network' type -updateGraph f = \s -> s { nGraph = f (nGraph s) } -updateLatchValues f = \s -> s { nLatchValues = f (nLatchValues s) } -updateDeps f = \s -> s { grDeps = f (grDeps s) } -updateCache f = \s -> s { grCache = f (grCache s) } -updateOutputCount f = \s -> s { grOutputCount = f (grOutputCount s) } - -emptyGraph :: Graph -emptyGraph = unsafePerformIO $ do - uid <- newUnique - return $ Graph - { grDeps = Deps.empty - , grCache = Lazy.empty - , grAlwaysP = Pulse - { evaluateP = return Deps.Children - , getValueP = const $ Just () - , uidP = uid - , nameP = "alwaysP" - } - , grOutputCount = 0 - } - --- | The 'Network' that contains no pulses or latches. -emptyNetwork :: Network -emptyNetwork = Network - { nGraph = emptyGraph - , nLatchValues = Dated.empty - , nTime = Dated.beginning - } - --- The 'Build' monad is used to change the graph, for example to --- * add nodes --- * change dependencies --- * add inputs or outputs -type BuildT = RWST () BuildConf Network -type Build = BuildT Identity -type BuildIO = BuildT IO - -type BuildConf = [IO ()] -- liftIOLater - -{- Note [BuildT] - -It is very convenient to be able to perform some IO functions -while (re)building a network graph. At the same time, -we need a good MonadFix instance to build recursive networks. -These requirements clash, so the solution is to split the types -into a pure variant and IO variant, the former having a good -MonadFix instance while the latter can do arbitrary IO. - --} - -{----------------------------------------------------------------------------- - Pulse and Latch -------------------------------------------------------------------------------} -{- - evaluateL/P - calculates the next value and makes sure that it's cached - getValueL/P - retrieves the current value - uidL/P - used for dependency tracking and evaluation order - nameP - used for debugging --} - -data Pulse a = Pulse - { evaluateP :: EvalP Deps.Continue - , getValueP :: Lazy.Vault -> Maybe a - , uidP :: Unique - , nameP :: String - } - -data Latch a = Latch - { getValueL :: Future (Dated.Box a) - } - -data LatchWrite = LatchWrite - { evaluateL :: EvalP EvalL - , uidL :: Unique - } - -data Output = Output - { evaluateO :: EvalP EvalO - , uidO :: Unique - , positionO :: Position - } - -type EvalP = StateT Lazy.Vault BuildIO - -- state: current pulse values - -type Future = Dated.Dated -type EvalL = Endo Dated.Vault -type EvalO = Future (IO ()) - -nop :: EvalO -nop = return $ return () - --- | Existential quantification for dependency tracking -data SomeNode - = forall a. P (Pulse a) - | L LatchWrite - | O Output - -instance Show SomeNode where show = show . hash - -instance Eq SomeNode where - (P x) == (P y) = uidP x == uidP y - (L x) == (L y) = uidL x == uidL y - (O x) == (O y) = uidO x == uidO y - _ == _ = False - -uid :: SomeNode -> Unique -uid (P x) = uidP x -uid (L x) = uidL x -uid (O x) = uidO x - -instance Hashable SomeNode where - hashWithSalt s = hashWithSalt s . uid - -{----------------------------------------------------------------------------- - Show functions for debugging -------------------------------------------------------------------------------} -showDeps :: Deps SomeNode -> String -showDeps deps = unlines $ - [ detail node ++ - if null children then "" else " -> " ++ unwords (map short children) - | node <- nodes - , let children = Deps.children deps node - ] - where - allChildren = Deps.allChildren deps - nodes = Set.toList . Set.fromList $ - concat [x : xs | (x,xs) <- allChildren] - dictionary = Map.fromList $ zip nodes [1..] - - short node = maybe "X" show $ Map.lookup node dictionary - - detail (P x) = "P " ++ nameP x ++ " " ++ short (P x) - detail (L x) = "L " ++ short (L x) - detail (O x) = "O " ++ short (O x) - diff --git a/src/Reactive/Banana/Switch.hs b/src/Reactive/Banana/Switch.hs deleted file mode 100644 --- a/src/Reactive/Banana/Switch.hs +++ /dev/null @@ -1,106 +0,0 @@ -{----------------------------------------------------------------------------- - Reactive Banana -------------------------------------------------------------------------------} -{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances #-} - -module Reactive.Banana.Switch ( - -- * Synopsis - -- | Dynamic event switching. - - -- * Moment monad - Moment, AnyMoment, anyMoment, now, - - -- * Dynamic event switching - trimE, trimB, - switchE, switchB, - observeE, valueB, - - -- * Identity Functor - Identity(..), - ) where - -import Control.Applicative -import Control.Monad - -import Reactive.Banana.Combinators -import qualified Reactive.Banana.Internal.Combinators as Prim -import Reactive.Banana.Types - -{----------------------------------------------------------------------------- - Constant -------------------------------------------------------------------------------} --- | Identity functor with a dummy argument. --- Unlike 'Data.Functor.Constant', --- this functor is constant in the /second/ argument. - -newtype Identity t a = Identity { getIdentity :: a } - -instance Functor (Identity t) where - fmap f (Identity a) = Identity (f a) - -{----------------------------------------------------------------------------- - Moment -------------------------------------------------------------------------------} --- | Value present at any/every moment in time. -newtype AnyMoment f a = AnyMoment { now :: forall t. Moment t (f t a) } - --- | Instance relying on the monad instance. -instance Functor (AnyMoment Identity) where - fmap = liftM - --- | Instance relying on the monad instance. -instance Applicative (AnyMoment Identity) where - pure = return - (<*>) = ap - -instance Monad (AnyMoment Identity) where - return x = AnyMoment $ return (Identity x) - (AnyMoment m) >>= g = AnyMoment $ m >>= \(Identity x) -> now (g x) - -instance Functor (AnyMoment Behavior) where - fmap f (AnyMoment x) = AnyMoment (fmap (fmap f) x) - -instance Applicative (AnyMoment Behavior) where - pure x = AnyMoment $ return $ pure x - (AnyMoment f) <*> (AnyMoment x) = AnyMoment $ liftM2 (<*>) f x - -instance Functor (AnyMoment Event) where - fmap f (AnyMoment x) = AnyMoment (fmap (fmap f) x) - -anyMoment :: (forall t. Moment t (f t a)) -> AnyMoment f a -anyMoment = AnyMoment - -{----------------------------------------------------------------------------- - Dynamic event switching -------------------------------------------------------------------------------} --- | Trim an 'Event' to a variable start time. -trimE :: Event t a -> Moment t (AnyMoment Event a) -trimE = M . fmap (\x -> AnyMoment (M $ fmap E x)) . Prim.trimE . unE - --- | Trim a 'Behavior' to a variable start time. -trimB :: Behavior t a -> Moment t (AnyMoment Behavior a) -trimB = M . fmap (\x -> AnyMoment (M $ fmap B x)) . Prim.trimB . unB - --- | Observe a value at those moments in time where --- event occurrences happen. -observeE :: Event t (AnyMoment Identity a) -> Event t a -observeE = E . Prim.observeE - . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE - --- | Obtain the value of the 'Behavior' at moment @t@. -valueB :: Behavior t a -> Moment t a -valueB = M . Prim.initialB . unB - --- | Dynamically switch between 'Event'. -switchE - :: forall t a. Event t (AnyMoment Event a) - -> Event t a -switchE = E . Prim.switchE . Prim.mapE (fmap unE . unM . now . last) . unE - --- | Dynamically switch between 'Behavior'. -switchB - :: forall t a. Behavior t a - -> Event t (AnyMoment Behavior a) - -> Behavior t a -switchB b e = B $ Prim.switchB (unB b) $ - Prim.mapE (fmap unB . unM . now . last) (unE e) diff --git a/src/Reactive/Banana/Test.hs b/src/Reactive/Banana/Test.hs deleted file mode 100644 --- a/src/Reactive/Banana/Test.hs +++ /dev/null @@ -1,200 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana - - Test cases and examples -------------------------------------------------------------------------------} -{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-} - -import Control.Arrow -import Control.Monad (when, join) - -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit (testCase) - -import Test.HUnit (assert, Assertion) - --- import Test.QuickCheck --- import Test.QuickCheck.Property - -import Control.Applicative -import Reactive.Banana.Test.Plumbing - - -main = defaultMain - [ testGroup "Simple" - [ testModelMatch "id" id - -- , testModelMatch "never1" never1 - , testModelMatch "fmap1" fmap1 - , testModelMatch "filter1" filter1 - , testModelMatch "filter2" filter2 - , testModelMatch "accumE1" accumE1 - ] - , testGroup "Complex" - [ testModelMatch "counter" counter - , testModelMatch "double" double - , testModelMatch "sharing" sharing - , testModelMatch "recursive1" recursive1 - , testModelMatch "recursive2" recursive2 - , testModelMatch "recursive3" recursive3 - , testModelMatch "recursive4a" recursive4a - , testModelMatch "recursive4b" recursive4b - , testModelMatch "accumBvsE" accumBvsE - ] - , testGroup "Dynamic Event Switching" - [ testModelMatch "observeE_id" observeE_id - , testModelMatchM "initialB_immediate" initialB_immediate - , testModelMatchM "initialB_recursive1" initialB_recursive1 - , testModelMatchM "initialB_recursive2" initialB_recursive2 - , testModelMatchM "dynamic_apply" dynamic_apply - , testModelMatchM "switchE1" switchE1 - , testModelMatchM "switchB_two" switchB_two - ] - -- TODO: - -- * algebraic laws - -- * larger examples - -- * quickcheck - ] - -{----------------------------------------------------------------------------- - Testing -------------------------------------------------------------------------------} -matchesModel - :: (Show b, Eq b) - => (Event a -> Moment (Event b)) -> [a] -> IO Bool -matchesModel f xs = do - bs1 <- return $ interpretModel f (singletons xs) - bs2 <- interpretGraph f (singletons xs) - -- bs3 <- interpretFrameworks f xs - let bs = [bs1,bs2] - let b = all (==bs1) bs - when (not b) $ mapM_ print bs - return b - -singletons = map Just - --- test whether model matches -testModelMatchM - :: (Show b, Eq b) - => String -> (Event Int -> Moment (Event b)) -> Test -testModelMatchM name f = testCase name $ assert $ matchesModel f [1..8::Int] -testModelMatch name f = testModelMatchM name (return . f) - --- individual tests for debugging -testModel :: (Event Int -> Event b) -> [Maybe b] -testModel f = interpretModel (return . f) $ singletons [1..8::Int] -testGraph f = interpretGraph (return . f) $ singletons [1..8::Int] - -testModelM f = interpretModel f $ singletons [1..8::Int] -testGraphM f = interpretGraph f $ singletons [1..8::Int] - - -{----------------------------------------------------------------------------- - Tests -------------------------------------------------------------------------------} -never1 :: Event Int -> Event Int -never1 = const never -fmap1 = fmap (+1) - -filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing) -filter1 = filterE (>= 3) -filter2 = filterE (>= 3) . fmap (subtract 1) -accumE1 = accumE 0 . ((+1) <$) - -counter e = applyE (pure const <*> bcounter) e - where bcounter = accumB 0 $ fmap (\_ -> (+1)) e - -merge e1 e2 = unionWith (++) (list e1) (list e2) - where list = fmap (:[]) - -double e = merge e e -sharing e = merge e1 e1 - where e1 = filterE (< 3) e -recursive1 e1 = e2 - where - e2 = applyE b e1 - b = (+) <$> stepperB 0 e2 -recursive2 e1 = e2 - where - e2 = applyE b e1 - b = (+) <$> stepperB 0 e3 - e3 = applyE (id <$> b) e1 -- actually equal to e2 - -type Dummy = Int - --- counter that can be decreased as long as it's >= 0 -recursive3 :: Event Dummy -> Event Int -recursive3 edec = applyE (const <$> bcounter) ecandecrease - where - bcounter = accumB 4 $ (subtract 1) <$ ecandecrease - ecandecrease = whenE ((>0) <$> bcounter) edec - --- Recursive 4 is an example reported by Merijn Verstraaten --- https://github.com/HeinrichApfelmus/reactive-banana/issues/56 --- Minimization: -recursive4a :: Event Int -> Event (Bool, Int) -recursive4a eInput = resultB <@ eInput - where - resultE = resultB <@ eInput - resultB = (,) <$> focus <*> pureB 0 - focus = stepperB False $ fst <$> resultE --- Full example: -recursive4b :: Event Int -> Event (Bool, Int) -recursive4b eInput = result <@ eInput - where - focus = stepperB False $ fst <$> result <@ eInput - interface = (,) <$> focus <*> cntrVal - (cntrVal, focusChange) = counter eInput focus - result = stepperB id ((***id) <$> focusChange) <*> interface - - filterApply :: Behavior (a -> Bool) -> Event a -> Event a - filterApply b e = filterJust $ sat <$> b <@> e - where sat p x = if p x then Just x else Nothing - - counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool)) - counter input active = (result, not <$ eq) - where - result = accumB 0 $ (+) <$> neq - eq = filterApply ((==) <$> result) input - neq = filterApply ((/=) <$> result) input - --- test accumE vs accumB -accumBvsE :: Event Dummy -> Event [Int] -accumBvsE e = merge e1 e2 - where - e1 = accumE 0 ((+1) <$ e) - e2 = let b = accumB 0 ((+1) <$ e) in applyE (const <$> b) e - - -observeE_id = observeE . fmap return -- = id - -initialB_immediate e = do - x <- initialB (stepper 0 e) - return $ x <$ e -initialB_recursive1 e1 = mdo - _ <- initialB b - let b = stepper 0 e1 - return $ b <@ e1 - --- NOTE: This test case tries to reproduce a situation --- where the value of a latch is used before the latch was created. --- This was relevant for the CRUD example, but I can't find a way --- to make it smaller right now. Oh well. -initialB_recursive2 e1 = mdo - x <- initialB b - let bf = const x <$ stepper 0 e1 - let b = stepper 0 $ (bf <*> b) <@ e1 - return $ b <@ e1 - -dynamic_apply e = do - mb <- trimB $ stepper 0 e - return $ observeE $ (initialB =<< mb) <$ e - -- = stepper 0 e <@ e -switchE1 e = do - me <- trimE e - return $ switchE $ me <$ e -switchB_two e = do - mb0 <- trimB $ stepper 0 $ filterE even e - mb1 <- trimB $ stepper 1 $ filterE odd e - b0 <- mb0 - let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e - return $ b <@ e diff --git a/src/Reactive/Banana/Test/Plumbing.hs b/src/Reactive/Banana/Test/Plumbing.hs deleted file mode 100644 --- a/src/Reactive/Banana/Test/Plumbing.hs +++ /dev/null @@ -1,107 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} --- * Synopsis --- | Merge model and implementation into a single type. Not pretty. - -module Reactive.Banana.Test.Plumbing where - -import Control.Applicative -import Control.Monad (liftM, ap) -import Control.Monad.Fix - -import qualified Reactive.Banana.Model as X -import qualified Reactive.Banana.Internal.Combinators as Y - -{----------------------------------------------------------------------------- - Types as pairs -------------------------------------------------------------------------------} - -data Event a = E (X.Event a) (Y.Event a) -data Behavior a = B (X.Behavior a) (Y.Behavior a) -data Moment a = M (X.Moment a) (Y.Moment a) - --- pair extractions -fstE (E x _) = x; sndE (E _ y) = y -fstB (B x _) = x; sndB (B _ y) = y -fstM (M x _) = x; sndM (M _ y) = y - --- partial embedding functions -ex x = E x undefined; ey y = E undefined y -bx x = B x undefined; by y = B undefined y -mx x = M x undefined; my y = M undefined y - --- interpretation -interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] -interpretModel f = X.interpret (fmap fstE . fstM . f . ex) - -interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] -interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey) - -{----------------------------------------------------------------------------- - Primitive combinators -------------------------------------------------------------------------------} -never = E X.never Y.never -filterJust (E x y) = E (X.filterJust x) (Y.filterJust y) -unionWith f (E x1 y1) (E x2 y2) = E (X.unionWith f x1 x2) (Y.unionWith f y1 y2) -mapE f (E x y) = E (X.mapE f x) (Y.mapE f y) -applyE ~(B x1 y1) (E x2 y2) = E (X.applyE x1 x2) (Y.applyE y1 y2) -accumE a (E x y) = E (X.accumE a x) (Y.accumE a y) - -instance Functor Event where fmap = mapE - -stepper = stepperB -stepperB a (E x y) = B (X.stepperB a x) (Y.stepperB a y) -pureB a = B (X.pureB a) (Y.pureB a) -applyB (B x1 y1) (B x2 y2) = B (X.applyB x1 x2) (Y.applyB y1 y2) -mapB f (B x y) = B (X.mapB f x) (Y.mapB f y) - -instance Functor Behavior where fmap = mapB -instance Applicative Behavior where pure = pureB; (<*>) = applyB - -instance Functor Moment where fmap = liftM -instance Applicative Moment where - pure = return - (<*>) = ap -instance Monad Moment where - return a = M (return a) (return a) - (M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g) -instance MonadFix Moment where - mfix f = M (mfix fx) (mfix fy) - where - fx a = let M x _ = f a in x - fy a = let M _ y = f a in y - -trimE :: Event a -> Moment (Moment (Event a)) -trimE (E x y) = M - (fmap (fmap ex . mx) $ X.trimE x) - (fmap (fmap ey . my) $ Y.trimE y) -trimB :: Behavior a -> Moment (Moment (Behavior a)) -trimB (B x y) = M - (fmap (fmap bx . mx) $ X.trimB x) - (fmap (fmap by . my) $ Y.trimB y) - -initialB ~(B x y) = M (X.initialB x) (Y.initialB y) - -observeE :: Event (Moment a) -> Event a -observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y) - -switchE :: Event (Moment (Event a)) -> Event a -switchE (E x y) = E - (X.switchE $ X.mapE (fstM . fmap fstE) x) - (Y.switchE $ Y.mapE (sndM . fmap sndE) y) - -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a -switchB (B x y) (E xe ye) = B - (X.switchB x $ X.mapE (fstM . fmap fstB) xe) - (Y.switchB y $ Y.mapE (sndM . fmap sndB) ye) - -{----------------------------------------------------------------------------- - Derived combinators -------------------------------------------------------------------------------} -accumB acc = stepperB acc . accumE acc -whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b) - -infixl 4 <@>, <@ -b <@ e = applyE (const <$> b) e -b <@> e = applyE b e diff --git a/src/Reactive/Banana/Types.hs b/src/Reactive/Banana/Types.hs --- a/src/Reactive/Banana/Types.hs +++ b/src/Reactive/Banana/Types.hs @@ -1,35 +1,160 @@ +{-# language CPP #-} + {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Types ( -- | Primitive types. - Event (..), Behavior (..), Moment (..), Future(..) + Event(..), Behavior(..), + Moment(..), MomentIO(..), MonadMoment(..), + Future(..), ) where import Control.Applicative -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix +import Data.String (IsString(..)) +import Control.Monad.Trans.Accum (AccumT) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST) +import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST) +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT) +import qualified Control.Monad.Trans.State.Strict as Strict (StateT) +import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT) +import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) -import qualified Reactive.Banana.Internal.Combinators as Prim -import Reactive.Banana.Internal.Phantom +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS (RWST) +import qualified Control.Monad.Trans.Writer.CPS as CPS (WriterT) +#endif -{-| @Event t a@ represents a stream of events as they occur in time. -Semantically, you can think of @Event t a@ as an infinite list of values -that are tagged with their corresponding time of occurence, +import qualified Reactive.Banana.Prim.High.Combinators as Prim -> type Event t a = [(Time,a)] +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} + +{-| @Event a@ represents a stream of events as they occur in time. +Semantically, you can think of @Event a@ as an infinite list of values +that are tagged with their corresponding time of occurrence, + +> type Event a = [(Time,a)] + +Each pair is called an /event occurrence/. +Note that within a single event stream, +no two event occurrences may happen at the same time. + +<> -} -newtype Event t a = E { unE :: Prim.Event [a] } +newtype Event a = E { unE :: Prim.Event a } +-- Invariant: The empty list `[]` never occurs as event value. -{-| @Behavior t a@ represents a value that varies in time. Think of it as +-- | The function 'fmap' applies a function @f@ to every value. +-- Semantically, +-- +-- > fmap :: (a -> b) -> Event a -> Event b +-- > fmap f e = [(time, f a) | (time, a) <- e] +instance Functor Event where + fmap f = E . Prim.mapE f . unE -> type Behavior t a = Time -> a +-- | The combinator '<>' merges two event streams of the same type. +-- In case of simultaneous occurrences, +-- the events are combined with the underlying 'Semigroup' operation. +-- Semantically, +-- +-- > (<>) :: Event a -> Event a -> Event a +-- > (<>) ex ey = unionWith (<>) ex ey +instance Semigroup a => Semigroup (Event a) where + x <> y = E $ Prim.mergeWith id id (<>) (unE x) (unE y) + +-- | The combinator 'mempty' represents an event that never occurs. +-- It is a synonym, +-- +-- > mempty :: Event a +-- > mempty = never +instance Semigroup a => Monoid (Event a) where + mempty = E Prim.never + mappend = (<>) + + +{-| @Behavior a@ represents a value that varies in time. +Semantically, you can think of it as a function + +> type Behavior a = Time -> a + +<> -} -newtype Behavior t a = B { unB :: Prim.Behavior a } +newtype Behavior a = B { unB :: Prim.Behavior a } +-- | The function 'pure' returns a value that is constant in time. Semantically, +-- +-- > pure :: a -> Behavior a +-- > pure x = \time -> x +-- +-- The combinator '<*>' applies a time-varying function to a time-varying value. +-- +-- > (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b +-- > fx <*> bx = \time -> fx time $ bx time +instance Applicative Behavior where + pure x = B $ Prim.pureB x + bf <*> bx = B $ Prim.applyB (unB bf) (unB bx) + +-- | The function 'fmap' applies a function @f@ at every point in time. +-- Semantically, +-- +-- > fmap :: (a -> b) -> Behavior a -> Behavior b +-- > fmap f b = \time -> f (b time) +instance Functor Behavior where + fmap = liftA + +instance Semigroup a => Semigroup (Behavior a) where + (<>) = liftA2 (<>) + +instance (Semigroup a, Monoid a) => Monoid (Behavior a) where + mempty = pure mempty + mappend = (<>) + +instance Num a => Num (Behavior a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + negate = fmap negate + +instance Fractional a => Fractional (Behavior a) where + (/) = liftA2 (/) + fromRational = pure . fromRational + recip = fmap recip + +instance Floating a => Floating (Behavior a) where + (**) = liftA2 (**) + acos = fmap acos + acosh = fmap acosh + asin = fmap asin + asinh = fmap asinh + atan = fmap atan + atanh = fmap atanh + cos = fmap cos + cosh = fmap cosh + exp = fmap exp + log = fmap log + logBase = liftA2 logBase + pi = pure pi + sin = fmap sin + sinh = fmap sinh + sqrt = fmap sqrt + +instance IsString a => IsString (Behavior a) where + fromString = pure . fromString + -- | The 'Future' monad is just a helper type for the 'changes' function. --- +-- -- A value of type @Future a@ is only available in the context -- of a 'reactimate' but not during event processing. newtype Future a = F { unF :: Prim.Future a } @@ -38,43 +163,87 @@ instance Functor Future where fmap f = F . fmap f . unF instance Monad Future where - return = F . return m >>= g = F $ unF m >>= unF . g instance Applicative Future where pure = F . pure f <*> a = F $ unF f <*> unF a -{-| The 'Moment' monad denotes a value at a particular /moment in time/. -This monad is not very interesting, it is mainly used for book-keeping. -In particular, the type parameter @t@ is used -to disallow various unhealthy programs. +{-| The 'Moment' monad denotes a /pure/ computation that happens +at one particular moment in time. Semantically, it is a reader monad -This monad is also used to describe event networks -in the "Reactive.Banana.Frameworks" module. -This only happens when the type parameter @t@ -is constrained by the 'Frameworks' class. +> type Moment a = Time -> a -To be precise, an expression of type @Moment t a@ denotes -a value of type @a@ that is observed at a moment in time -which is indicated by the type parameter @t@. +When run, the argument tells the time at which this computation happens. +Note that in this context, /time/ really means to /logical time/. +Of course, every calculation on a computer takes some +amount of wall-clock time to complete. +Instead, what is meant here is the time as it relates to +'Event's and 'Behavior's. +We use the fiction that every calculation within the 'Moment' +monad takes zero /logical time/ to perform. -} -newtype Moment t a = M { unM :: Prim.Moment a } +newtype Moment a = M { unM :: Prim.Moment a } --- boilerplate class instances -instance Functor (Moment t) where fmap f = M . fmap f . unM +{-| The 'MomentIO' monad is used to add inputs and outputs +to an event network. +-} +newtype MomentIO a = MIO { unMIO :: Prim.Moment a } -instance Monad (Moment t) where - return = M . return - m >>= g = M $ unM m >>= unM . g +instance MonadIO MomentIO where liftIO = MIO . liftIO -instance Applicative (Moment t) where +{-| An instance of the 'MonadMoment' class denotes a computation +that happens at one particular moment in time. +Unlike the 'Moment' monad, it need not be pure anymore. +-} +class MonadFix m => MonadMoment m where + liftMoment :: Moment a -> m a + +instance MonadMoment Moment where liftMoment = id +instance MonadMoment MomentIO where liftMoment = MIO . unM +instance (MonadMoment m, Monoid w) => MonadMoment (AccumT w m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (ExceptT e m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (IdentityT m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (MaybeT m) where liftMoment = lift . liftMoment +instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.RWST r w s m) where liftMoment = lift . liftMoment +instance (MonadMoment m, Monoid w) => MonadMoment (Strict.RWST r w s m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (ReaderT r m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (Lazy.StateT s m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (Strict.StateT s m) where liftMoment = lift . liftMoment +instance (MonadMoment m, Monoid w) => MonadMoment (Lazy.WriterT w m) where liftMoment = lift . liftMoment +instance (MonadMoment m, Monoid w) => MonadMoment (Strict.WriterT w m) where liftMoment = lift . liftMoment + +#if MIN_VERSION_transformers(0,5,6) +instance MonadMoment m => MonadMoment (CPS.RWST r w s m) where liftMoment = lift . liftMoment +instance MonadMoment m => MonadMoment (CPS.WriterT w m) where liftMoment = lift . liftMoment +#endif + +-- boilerplate class instances +instance Functor Moment where fmap f = M . fmap f . unM +instance Monad Moment where + m >>= g = M $ unM m >>= unM . g +instance Applicative Moment where pure = M . pure f <*> a = M $ unM f <*> unM a +instance MonadFix Moment where mfix f = M $ mfix (unM . f) -instance MonadFix (Moment t) where mfix f = M $ mfix (unM . f) +instance Semigroup a => Semigroup (Moment a) where + (<>) = liftA2 (<>) +instance Monoid a => Monoid (Moment a) where + mempty = pure mempty -instance Frameworks t => MonadIO (Moment t) where - liftIO = M . Prim.liftIONow + +instance Functor MomentIO where fmap f = MIO . fmap f . unMIO +instance Monad MomentIO where + m >>= g = MIO $ unMIO m >>= unMIO . g +instance Applicative MomentIO where + pure = MIO . pure + f <*> a = MIO $ unMIO f <*> unMIO a +instance MonadFix MomentIO where mfix f = MIO $ mfix (unMIO . f) + +instance Semigroup a => Semigroup (MomentIO a) where + (<>) = liftA2 (<>) +instance Monoid a => Monoid (MomentIO a) where + mempty = pure mempty diff --git a/test/Reactive/Banana/Test/High/Combinators.hs b/test/Reactive/Banana/Test/High/Combinators.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/High/Combinators.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecursiveDo #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Exemplar test for various high-level combinators. +module Reactive.Banana.Test.High.Combinators + ( tests + ) where + +import Control.Applicative +import Control.Arrow +import Control.Monad + ( when, join ) +import Test.Tasty + ( defaultMain, testGroup, TestTree ) +import Test.Tasty.HUnit + ( testCase, assertBool ) + +import Reactive.Banana.Test.High.Plumbing + +tests :: TestTree +tests = testGroup "Combinators, high level" + [ testGroup "Simple" + [ testModelMatch "id" id + , testModelMatch "never1" never1 + , testModelMatch "fmap1" fmap1 + , testModelMatch "filter1" filter1 + , testModelMatch "filter2" filter2 + , testModelMatchM "accumE1" accumE1 + ] + , testGroup "Complex" + [ testModelMatchM "counter" counter + , testModelMatch "double" double + , testModelMatch "sharing" sharing + , testModelMatch "mergeFilter" mergeFilter + , testModelMatchM "recursive1A" recursive1A + , testModelMatchM "recursive1B" recursive1B + , testModelMatchM "recursive2" recursive2 + , testModelMatchM "recursive3" recursive3 + , testModelMatchM "recursive4a" recursive4a + -- , testModelMatchM "recursive4b" recursive4b + , testModelMatchM "accumBvsE" accumBvsE + ] + , testGroup "Dynamic Event Switching" + [ testModelMatch "observeE_id" observeE_id + , testModelMatch "observeE_stepper" observeE_stepper + , testModelMatchM "valueB_immediate" valueB_immediate + -- , testModelMatchM "valueB_recursive1" valueB_recursive1 + -- , testModelMatchM "valueB_recursive2" valueB_recursive2 + , testModelMatchM "dynamic_apply" dynamic_apply + , testModelMatchM "switchE1" switchE1 + , testModelMatchM "switchB1" switchB1 + , testModelMatchM "switchB2" switchB2 + ] + , testGroup "Regression tests" + [ testModelMatchM "issue79" issue79 + ] + -- TODO: + -- * algebraic laws + -- * larger examples + -- * quickcheck + ] + +{----------------------------------------------------------------------------- + Testing +------------------------------------------------------------------------------} +matchesModel + :: (Show b, Eq b) + => (Event a -> Moment (Event b)) -> [a] -> IO Bool +matchesModel f xs = do + bs1 <- return $ interpretModel f (singletons xs) + bs2 <- interpretGraph f (singletons xs) + -- bs3 <- interpretFrameworks f xs + let bs = [bs1,bs2] + let b = all (==bs1) bs + when (not b) $ mapM_ print bs + return b + +singletons = map Just + +-- test whether model matches +testModelMatchM + :: (Show b, Eq b) + => String -> (Event Int -> Moment (Event b)) -> TestTree +testModelMatchM name f = testCase name $ assertBool "matchesModel" =<< matchesModel f [1..8::Int] +testModelMatch name f = testModelMatchM name (return . f) + +-- individual tests for debugging +testModel :: (Event Int -> Event b) -> [Maybe b] +testModel f = interpretModel (return . f) $ singletons [1..8::Int] +testGraph f = interpretGraph (return . f) $ singletons [1..8::Int] + +testModelM f = interpretModel f $ singletons [1..8::Int] +testGraphM f = interpretGraph f $ singletons [1..8::Int] + + +{----------------------------------------------------------------------------- + Tests +------------------------------------------------------------------------------} +never1 :: Event Int -> Event Int +never1 = const never +fmap1 = fmap (+1) + +filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing) +filter1 = filterE (>= 3) +filter2 = filterE (>= 3) . fmap (subtract 1) +accumE1 = accumE 0 . ((+1) <$) + +counter e = do + bcounter <- accumB 0 $ fmap (\_ -> (+1)) e + return $ applyE (pure const <*> bcounter) e + +merge e1 e2 = mergeWith id id (++) (list e1) (list e2) + where list = fmap (:[]) + +double e = merge e e +sharing e = merge e1 e1 + where e1 = filterE (< 3) e + +mergeFilter e1 = mergeWith id id (+) e2 e3 + where + e3 = fmap (+1) $ filterE even e1 + e2 = fmap (+1) $ filterE odd e1 + +recursive1A e1 = mdo + let e2 = applyE ((+) <$> b) e1 + b <- stepperB 0 e2 + return e2 +recursive1B e1 = mdo + b <- stepperB 0 e2 + let e2 = applyE ((+) <$> b) e1 + return e2 + +recursive2 e1 = mdo + b <- fmap ((+) <$>) $ stepperB 0 e3 + let e2 = applyE b e1 + let e3 = applyE (id <$> b) e1 -- actually equal to e2 + return e2 + +type Dummy = Int + +-- Counter that can be decreased as long as it's >= 0 . +recursive3 :: Event Dummy -> Moment (Event Int) +recursive3 edec = mdo + bcounter <- accumB 4 $ (subtract 1) <$ ecandecrease + let ecandecrease = whenE ((>0) <$> bcounter) edec + return $ applyE (const <$> bcounter) ecandecrease + +-- Recursive 4 is an example reported by Merijn Verstraaten +-- https://github.com/HeinrichApfelmus/reactive-banana/issues/56 +-- Minimization: +recursive4a :: Event Int -> Moment (Event (Bool, Int)) +recursive4a eInput = mdo + focus <- stepperB False $ fst <$> resultE + let resultE = resultB <@ eInput + let resultB = (,) <$> focus <*> pureB 0 + return $ resultB <@ eInput + +{- +-- Full example: +recursive4b :: Event Int -> Event (Bool, Int) +recursive4b eInput = result <@ eInput + where + focus = stepperB False $ fst <$> result <@ eInput + interface = (,) <$> focus <*> cntrVal + (cntrVal, focusChange) = counter eInput focus + result = stepperB id ((***id) <$> focusChange) <*> interface + + filterApply :: Behavior (a -> Bool) -> Event a -> Event a + filterApply b e = filterJust $ sat <$> b <@> e + where sat p x = if p x then Just x else Nothing + + counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool)) + counter input active = (result, not <$ eq) + where + result = accumB 0 $ (+) <$> neq + eq = filterApply ((==) <$> result) input + neq = filterApply ((/=) <$> result) input +-} + +-- Test 'accumE' vs 'accumB'. +accumBvsE :: Event Dummy -> Moment (Event [Int]) +accumBvsE e = mdo + e1 <- accumE 0 ((+1) <$ e) + + b <- accumB 0 ((+1) <$ e) + let e2 = applyE (const <$> b) e + + return $ merge e1 e2 + +observeE_id = observeE . fmap return -- = id + +observeE_stepper :: Event Int -> Event Int +observeE_stepper e = observeE $ (valueB =<< mb) <$ e + where + mb :: Moment (Behavior Int) + mb = stepper 0 e + +valueB_immediate e = do + x <- valueB =<< stepper 0 e + return $ x <$ e + +{-- The following tests would need to use the valueBLater combinator + +valueB_recursive1 e1 = mdo + _ <- initialB b + let b = stepper 0 e1 + return $ b <@ e1 + +valueB_recursive2 e1 = mdo + x <- initialB b + let bf = const x <$ stepper 0 e1 + let b = stepper 0 $ (bf <*> b) <@ e1 + return $ b <@ e1 +-} + +dynamic_apply e = do + b <- stepper 0 e + return $ observeE $ (valueB b) <$ e + -- = stepper 0 e <@ e + +switchE1 e = switchE e (e <$ e) + +switchB1 e = do + b0 <- stepper 0 e + b1 <- stepper 0 e + b <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e + return $ b <@ e + +switchB2 e = do + b0 <- stepper 0 $ filterE even e + b1 <- stepper 1 $ filterE odd e + b <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e + return $ b <@ e + +{----------------------------------------------------------------------------- + Regression tests +------------------------------------------------------------------------------} +issue79 :: Event Dummy -> Moment (Event String) +issue79 inputEvent = mdo + let + appliedEvent = (\_ _ -> 1) <$> lastValue <@> inputEvent + filteredEvent = filterE (const True) appliedEvent + fmappedEvent = fmap id (filteredEvent) + lastValue <- stepper 1 $ fmappedEvent + + let outputEvent = mergeWith id id (++) + (const "filtered event" <$> filteredEvent) + (((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent) + + return $ outputEvent + diff --git a/test/Reactive/Banana/Test/High/Plumbing.hs b/test/Reactive/Banana/Test/High/Plumbing.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/High/Plumbing.hs @@ -0,0 +1,104 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- * Synopsis +-- | Merge model and implementation into a single type. Not pretty. +module Reactive.Banana.Test.High.Plumbing where + +import Control.Applicative +import Control.Monad (liftM, ap) +import Control.Monad.Fix + +import qualified Reactive.Banana.Model as X +import qualified Reactive.Banana as Y + +{----------------------------------------------------------------------------- + Types as pairs +------------------------------------------------------------------------------} + +data Event a = E (X.Event a) (Y.Event a) +data Behavior a = B (X.Behavior a) (Y.Behavior a) +data Moment a = M (X.Moment a) (Y.Moment a) + +-- pair extractions +fstE (E x _) = x; sndE (E _ y) = y +fstB (B x _) = x; sndB (B _ y) = y +fstM (M x _) = x; sndM (M _ y) = y + +-- partial embedding functions +ex x = E x undefined; ey y = E undefined y +bx x = B x undefined; by y = B undefined y +mx x = M x undefined; my y = M undefined y + +-- interpretation +interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] +interpretModel f = X.interpret (fmap fstE . fstM . f . ex) + +interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] +interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey) + +{----------------------------------------------------------------------------- + Primitive combinators +------------------------------------------------------------------------------} +never = E X.never Y.never +filterJust (E x y) = E (X.filterJust x) (Y.filterJust y) +mergeWith f g h (E x1 y1) (E x2 y2) = E (X.mergeWith f g h x1 x2) (Y.mergeWith f g h y1 y2) +mapE f (E x y) = E (fmap f x) (fmap f y) +applyE ~(B x1 y1) (E x2 y2) = E (X.apply x1 x2) (y1 Y.<@> y2) + +instance Functor Event where fmap = mapE + +pureB a = B (pure a) (pure a) +applyB (B x1 y1) (B x2 y2) = B (x1 <*> x2) (y1 <*> y2) +mapB f (B x y) = B (fmap f x) (fmap f y) + +instance Functor Behavior where fmap = mapB +instance Applicative Behavior where pure = pureB; (<*>) = applyB + +instance Functor Moment where fmap = liftM +instance Applicative Moment where + pure a = M (pure a) (pure a) + (<*>) = ap +instance Monad Moment where + ~(M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g) +instance MonadFix Moment where + mfix f = M (mfix fx) (mfix fy) + where + fx a = let M x _ = f a in x + fy a = let M _ y = f a in y + + +accumE a ~(E x y) = M + (ex <$> X.accumE a x) + (ey <$> Y.accumE a y) +stepperB a ~(E x y) = M + (bx <$> X.stepper a x) + (by <$> Y.stepper a y) +stepper = stepperB + +valueB ~(B x y) = M (X.valueB x) (Y.valueB y) + +observeE :: Event (Moment a) -> Event a +observeE (E x y) = E (X.observeE $ fmap fstM x) (Y.observeE $ fmap sndM y) + +switchE :: Event a -> Event (Event a) -> Moment (Event a) +switchE (E x0 y0) (E x y) = M + (fmap ex $ X.switchE x0 $ fstE <$> x) + (fmap ey $ Y.switchE y0 $ sndE <$> y) + +switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a) +switchB (B x y) (E xe ye) = M + (fmap bx $ X.switchB x $ fmap fstB xe) + (fmap by $ Y.switchB y $ fmap sndB ye) + +{----------------------------------------------------------------------------- + Derived combinators +------------------------------------------------------------------------------} +accumB acc e1 = do + e2 <- accumE acc e1 + stepperB acc e2 +whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b) + +infixl 4 <@>, <@ +b <@ e = applyE (const <$> b) e +b <@> e = applyE b e diff --git a/test/Reactive/Banana/Test/High/Space.hs b/test/Reactive/Banana/Test/High/Space.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/High/Space.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecursiveDo #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Exemplar tests for space usage and garbage collection. +module Reactive.Banana.Test.High.Space where + +import Control.Monad + ( forM ) +import Test.Tasty + ( testGroup, TestTree ) +import Test.Tasty.QuickCheck + ( testProperty ) + +import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck.Monadic as Q + +import qualified Control.Exception as Memory +import qualified Control.Concurrent as System +import qualified System.Mem as System + +import Reactive.Banana +import Reactive.Banana.Frameworks + +tests :: TestTree +tests = testGroup "Space usage, high level" + [ testGroup "Network size stays bounded" + [ testBoundedNetworkSize "execute" execute1 + , testBoundedNetworkSize "observe accumE, issue #261" observeAccumE1 + , testBoundedNetworkSize "execute accumE, issue #261" executeAccumE1 + , testBoundedNetworkSize "switch accumE, issue #261" switchAccumE1 + ] + ] + +{----------------------------------------------------------------------------- + Tests +------------------------------------------------------------------------------} +execute1 :: Event Int -> MomentIO (Event (Event Int)) +execute1 e = execute $ (\i -> liftIO $ Memory.evaluate (i <$ e)) <$> e + +observeAccumE1 :: Event Int -> MomentIO (Event (Event ())) +observeAccumE1 e = pure $ observeE (accumE () never <$ e) + +executeAccumE1 :: Event Int -> MomentIO (Event (Event ())) +executeAccumE1 e = execute (accumE () (id <$ e) <$ e) + +switchAccumE1 :: Event Int -> MomentIO (Event ()) +switchAccumE1 e = do + let e2 :: Event (Event ()) + e2 = observeE (accumE () (id <$ e) <$ e) + switchE never e2 + +{----------------------------------------------------------------------------- + Test harness +------------------------------------------------------------------------------} +-- | Execute an FRP network with a sequence of inputs +-- with intermittend of garbage collection and record network sizes. +runNetworkSizes + :: (Event a -> MomentIO (Event ignore)) + -> [a] -> IO [Int] +runNetworkSizes f xs = do + (network, fire) <- setup + run network fire + where + setup = do + (ah, fire) <- newAddHandler + network <- compile $ do + ein <- fromAddHandler ah + eout <- f ein + reactimate $ pure () <$ eout + performSufficientGC + actuate network + pure (network, fire) + + run network fire = forM xs $ \i -> do + fire i + performSufficientGC + System.yield + Memory.evaluate =<< getSize network + +-- | Test whether the network size stays bounded. +testBoundedNetworkSize + :: String + -> (Event Int -> MomentIO (Event ignore)) + -> TestTree +testBoundedNetworkSize name f = testProperty name $ + Q.once $ Q.monadicIO $ do + sizes <- liftIO $ runNetworkSizes f [1..n] + Q.monitor + $ Q.counterexample "network size grows" + . Q.counterexample ("network sizes: " <> show sizes) + Q.assert $ isBounded sizes + where + n = 20 :: Int + isBounded sizes = sizes !! 3 >= sizes !! (n-1) + +performSufficientGC :: IO () +performSufficientGC = System.performMinorGC diff --git a/test/Reactive/Banana/Test/Low/Gen.hs b/test/Reactive/Banana/Test/Low/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/Low/Gen.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NamedFieldPuns #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Generation of intereseting example graphs. +module Reactive.Banana.Test.Low.Gen + ( + -- * Simple graph types for testing + TestGraph (..) + , DeltaGraph (..) + , Vertex + + -- * Example graphs + , mkLinearChain + , mkSquare + + -- * Generators + , genTestGraph + , genLinearChain + , genSquare + , genSquareSide + , shuffleEdges + ) where + +import Test.QuickCheck + ( Gen ) +import qualified Test.QuickCheck as Q + +{----------------------------------------------------------------------------- + Graphs for testing +------------------------------------------------------------------------------} +type Vertex = Int + +data DeltaGraph + = InsertEdge Vertex Vertex + deriving (Eq, Show) + +data TestGraph = TestGraph + { vertices :: [Vertex] + , edges :: [DeltaGraph] + } deriving (Eq, Show) + +{----------------------------------------------------------------------------- + Interesting example graphs +------------------------------------------------------------------------------} +-- | A linear chain 1 -> 2 -> 3 -> … -> n . +mkLinearChain :: Int -> TestGraph +mkLinearChain n = TestGraph{vertices,edges} + where + vertices = [1..n] + edges = zipWith InsertEdge vertices (drop 1 vertices) + +-- | A cartesian product of linear chains +mkSquare :: Int -> TestGraph +mkSquare n = TestGraph{vertices,edges} + where + toInt (x,y) = (x-1) + n*(y-1) + 1 + vertices = [ toInt (x,y) | y <- [1..n], x <- [1..n]] + edges = + [ InsertEdge (toInt (x,y)) (toInt (x+1,y)) + | y <- [1..n] + , x <- [1..n-1] + ] + ++ + [ InsertEdge (toInt (x,y)) (toInt (x,y+1)) + | y <- [1..n-1] + , x <- [1..n] + ] + +{----------------------------------------------------------------------------- + Generating various graphs +------------------------------------------------------------------------------} +-- | Interesting generator for 'TestGraph'. +genTestGraph :: Gen TestGraph +genTestGraph = shuffleEdges =<< Q.frequency + [ (1, genLinearChain) + , (1, genSquare) + ] + +shuffleEdges :: TestGraph -> Gen TestGraph +shuffleEdges g@TestGraph{edges} = (\e -> g{edges = e})<$> Q.shuffle edges + +genLinearChain :: Gen TestGraph +genLinearChain = Q.sized $ pure . mkLinearChain + +genSquare :: Gen TestGraph +genSquare = mkSquare <$> genSquareSide + +genSquareSide :: Gen Int +genSquareSide = Q.sized $ \n -> Q.chooseInt (2,floorSqrt (2*n) + 2) + +floorSqrt :: Int -> Int +floorSqrt = floor . sqrt . fromIntegral diff --git a/test/Reactive/Banana/Test/Low/Graph.hs b/test/Reactive/Banana/Test/Low/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/Low/Graph.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NamedFieldPuns #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Property tests for 'Graph'. +module Reactive.Banana.Test.Low.Graph + ( tests + , mkGraph + ) where + +import Reactive.Banana.Prim.Low.Graph + ( Graph ) +import Reactive.Banana.Test.Low.Gen + ( DeltaGraph (..), TestGraph (..), Vertex ) +import Test.QuickCheck + ( Gen, Property, (===), (=/=) ) +import Test.Tasty + ( testGroup, TestTree ) +import Test.Tasty.QuickCheck + ( testProperty ) + +import qualified Data.List as List +import qualified Test.QuickCheck as Q +import qualified Reactive.Banana.Test.Low.Gen as Q + +import qualified Reactive.Banana.Prim.Low.Graph as Graph + +tests :: TestTree +tests = testGroup "Graph" + [ testGroup "walkSuccessors" + [ testProperty "Predecessors have lower levels" prop_levelsInvariant + , testProperty "succeeds on a square" prop_walkSquare + ] + ] + +{----------------------------------------------------------------------------- + Properties +------------------------------------------------------------------------------} +prop_levelsInvariant :: Property +prop_levelsInvariant = Q.forAll Q.genTestGraph $ \g0 -> + let g = mkGraph g0 + level x = Graph.getLevel g x + in + Q.conjoin [ level x < level y | InsertEdge x y <- edges g0 ] + +-- | Run 'walkSuccessors' on a square (with edges inserted randomly). +walkSquare :: Int -> Gen [Vertex] +walkSquare n = do + g <- mkGraph <$> Q.shuffleEdges (Q.mkSquare n) + Graph.walkSuccessors [1] (const step) g + where + step = Q.frequency [(10,pure Graph.Next), (1,pure Graph.Stop)] + +prop_walkSquare :: Property +prop_walkSquare = + Q.forAll Q.genSquareSide + $ \n -> Q.cover 10 (n >= 10) "large square" + $ Q.forAll (walkSquare n) + $ \walk -> + let correctOrder (x,y) = + Q.counterexample (show y <> " precedes " <> show x) + $ not $ (fromInt n y) `before` (fromInt n x) + + checkOrder = Q.conjoin $ replicate 10 $ do + m <- Q.chooseInt (1, length walk - 1) + pure + $ Q.conjoin + $ map correctOrder + $ pairsFromPivot m walk + + in Q.counterexample ("Walk result: " <> show walk) + $ length walk >= 1 + where + fromInt :: Int -> Vertex -> (Int, Int) + fromInt n x = ((x-1) `mod` n, (x-1) `div` n) + + (x1,y1) `before` (x2,y2) = x1 <= x2 && y1 <= y2 + +pairsFromPivot :: Int -> [a] -> [(a,a)] +pairsFromPivot n [] = [] +pairsFromPivot n xs = [(a,b) | a <- as] ++ [(b,c) | c <- cs] + where + (as, b:cs) = splitAt m xs + m = max (length xs - 1) $ min 0 $ n + +{----------------------------------------------------------------------------- + Test graphs +------------------------------------------------------------------------------} +-- | Generate a 'Graph' from a 'TestGraph'. +mkGraph :: TestGraph -> Graph Vertex () +mkGraph TestGraph{edges} = List.foldl' insertEdge Graph.empty edges + where + insertEdge g (InsertEdge x y) = Graph.insertEdge (x,y) () g diff --git a/test/Reactive/Banana/Test/Low/GraphGC.hs b/test/Reactive/Banana/Test/Low/GraphGC.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/Low/GraphGC.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Property tests for 'GraphGC'. +module Reactive.Banana.Test.Low.GraphGC + ( tests + ) where + +import Control.Monad + ( when ) +import Control.Monad.IO.Class + ( liftIO ) +import Data.Map.Strict + ( Map ) +import Data.Unique.Really + ( Unique ) +import Reactive.Banana.Prim.Low.Graph + ( Graph ) +import Reactive.Banana.Prim.Low.GraphGC + ( GraphGC ) +import Reactive.Banana.Test.Low.Gen + ( DeltaGraph (..), TestGraph (..), Vertex ) +import Test.QuickCheck + ( Gen, Property, (===), (=/=) ) +import Test.Tasty + ( testGroup, TestTree ) +import Test.Tasty.QuickCheck + ( testProperty ) + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Control.DeepSeq as Memory +import qualified Control.Exception as Memory +import qualified System.Mem as System +import qualified Control.Concurrent as System + +import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck.Monadic as Q +import qualified Reactive.Banana.Test.Low.Graph as Q +import qualified Reactive.Banana.Test.Low.Gen as Q + +import qualified Reactive.Banana.Prim.Low.Graph as Graph +import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC +import qualified Reactive.Banana.Prim.Low.Ref as Ref + + +tests :: TestTree +tests = testGroup "GraphGC" + [ testGroup "Garbage collection (GC)" + [ testProperty "retains the reachable vertices" prop_performGC + , testProperty "not doing GC retains all vertices" prop_notPerformGC + ] + ] + +{----------------------------------------------------------------------------- + Properties +------------------------------------------------------------------------------} +prop_performGC :: Property +prop_performGC = + Q.forAll Q.genTestGraph + $ \g0 -> Q.forAll (genGarbageCollectionRoots g0) + $ \roots -> + let g = Q.mkGraph g0 + expected = Graph.collectGarbage roots g + in Q.cover 10 (Graph.size g == Graph.size expected) + "no vertices unreachable" + $ Q.cover 75 (Graph.size g > Graph.size expected) + "some vertices unreachable" + $ Q.cover 15 (Graph.size g > 2*Graph.size expected) + "many vertices unreachable" + $ Q.monadicIO $ liftIO $ do + (actual, vertices) <- mkGraphGC g0 + let rootRefs = map (vertices Map.!) roots + Memory.evaluate $ Memory.rnf rootRefs + + System.performMajorGC + GraphGC.removeGarbage actual + reachables <- traverse Ref.read =<< + GraphGC.listReachableVertices actual + + -- keep rootsRef reachable until this point + rootsFromRef <- traverse Ref.read rootRefs + + pure $ + ( roots === rootsFromRef ) + Q..&&. + ( Set.fromList (Graph.listConnectedVertices expected) + === Set.fromList reachables + ) + +prop_notPerformGC :: Property +prop_notPerformGC = + Q.forAll Q.genSquareSide + $ \n -> Q.monadicIO $ liftIO $ do + -- Trigger a garbage collection now so that it is + -- highly unlikely to happen in the subsequent lines + System.performMinorGC + + let g = Q.mkLinearChain n + + (actual, _) <- mkGraphGC g + GraphGC.removeGarbage actual + reachables <- traverse Ref.read =<< + GraphGC.listReachableVertices actual + + pure $ + Set.fromList reachables === Set.fromList [1..n] + +{----------------------------------------------------------------------------- + Test graphs +------------------------------------------------------------------------------} +-- | Generate a 'GraphGC' from a 'TestGraph'. +mkGraphGC :: TestGraph -> IO (GraphGC Vertex, Map Vertex (Ref.Ref Vertex)) +mkGraphGC TestGraph{vertices,edges} = do + g <- GraphGC.new + refMap <- Map.fromList . zip vertices <$> traverse Ref.new vertices + let insertEdge (InsertEdge x y) = do + GraphGC.insertEdge (refMap Map.! x, refMap Map.! y) g + traverse insertEdge edges + pure (g, refMap) + +-- | Randomly generate a set of garbage collection roots. +genGarbageCollectionRoots :: TestGraph -> Gen [Vertex] +genGarbageCollectionRoots TestGraph{vertices} = Q.sized $ \n -> + sequence . replicate (n `mod` 10) $ Q.elements vertices diff --git a/test/Reactive/Banana/Test/Mid/Space.hs b/test/Reactive/Banana/Test/Mid/Space.hs new file mode 100644 --- /dev/null +++ b/test/Reactive/Banana/Test/Mid/Space.hs @@ -0,0 +1,122 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +-- | Exemplar tests for space usage and garbage collection. +module Reactive.Banana.Test.Mid.Space where + +import Control.Monad + ( foldM ) +import Control.Monad.IO.Class + ( liftIO ) +import Test.Tasty + ( testGroup, TestTree ) +import Test.Tasty.QuickCheck + ( testProperty ) + +import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck.Monadic as Q + +import qualified Control.Exception as Memory +import qualified Control.Concurrent as System +import qualified System.Mem as System + +import Reactive.Banana.Prim.Mid + ( Build, BuildIO, Network, Pulse, Latch ) +import qualified Reactive.Banana.Prim.Mid as Prim + +tests :: TestTree +tests = testGroup "Space usage, mid level" + [ testGroup "Network size stays bounded" + [ testBoundedNetworkSize "executeP accumL" executeAccum1 + , testBoundedNetworkSize "switchP executeP accumL" switchAccum1 + ] + ] + +{----------------------------------------------------------------------------- + Tests +------------------------------------------------------------------------------} +executeAccum1 :: Pulse Int -> Build (Pulse (Pulse Int)) +executeAccum1 p1 = do + p2 <- Prim.mapP mkP p1 + Prim.executeP p2 () + where + mkP :: Int -> () -> Build (Pulse Int) + mkP i () = do + piId <- Prim.mapP (const id) p1 + (_, pi) <- Prim.accumL i piId + pure pi + +switchAccum1 :: Pulse Int -> Build (Pulse Int) +switchAccum1 p1 = do + p2 <- executeAccum1 p1 + Prim.switchP p1 p2 + +{----------------------------------------------------------------------------- + Test harness +------------------------------------------------------------------------------} +-- | Compile an FRP network description into a state machine, +-- which also performs garbage collection after every step. +compileToStateMachine + :: (Pulse a -> BuildIO (Pulse ignore)) + -> IO (Network, a -> Network -> IO Network) +compileToStateMachine f = do + (step,network0) <- Prim.compile build =<< Prim.emptyNetwork + pure (network0, doStep step) + where + build = do + (p1, step) <- Prim.newInput + p2 <- f p1 + p3 <- Prim.mapP pure p2 -- wrap into Future + Prim.addHandler p3 (\_ -> pure ()) + pure step + + doStep step x network1 = do + (outputs, network2) <- step x network1 + outputs -- don't forget to execute outputs + performSufficientGC + System.yield -- wait for finalizers to run + pure network2 + +-- | Execute an FRP network with a sequence of inputs +-- with intermittend of garbage collection and record network sizes. +runNetworkSizes + :: (Pulse a -> BuildIO (Pulse ignore)) + -> [a] -> IO [Int] +runNetworkSizes f xs = do + (network0, step0) <- compileToStateMachine f + let step1 x network1 = do + network2 <- step0 x network1 + size <- Memory.evaluate =<< Prim.getSize network2 + pure (size, network2) + fst <$> Prim.mapAccumM step1 network0 xs + +-- | Test whether the network size stays bounded. +testBoundedNetworkSize + :: String + -> (Pulse Int -> Build (Pulse ignore)) + -> TestTree +testBoundedNetworkSize name f = testProperty name $ + Q.once $ Q.monadicIO $ do + sizes <- liftIO $ runNetworkSizes f [1..n] + Q.monitor + $ Q.counterexample "network size grows" + . Q.counterexample ("network sizes: " <> show sizes) + Q.assert $ isBounded sizes + where + n = 20 :: Int + isBounded sizes = sizes !! 3 >= sizes !! (n-1) + +performSufficientGC :: IO () +performSufficientGC = System.performMinorGC + +{----------------------------------------------------------------------------- + Debugging +------------------------------------------------------------------------------} +-- | Print network after a given sequence of inputs +printNetwork + :: (Pulse a -> BuildIO (Pulse ignore)) + -> [a] -> IO String +printNetwork f xs = do + (network0, step) <- compileToStateMachine f + network1 <- foldM (flip step) network0 xs + Prim.printDot network1 diff --git a/test/reactive-banana-tests.hs b/test/reactive-banana-tests.hs new file mode 100644 --- /dev/null +++ b/test/reactive-banana-tests.hs @@ -0,0 +1,27 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Main where + +import Test.Tasty + ( defaultMain, testGroup ) + +import qualified Reactive.Banana.Test.Low.Graph +import qualified Reactive.Banana.Test.Low.GraphGC +import qualified Reactive.Banana.Test.Mid.Space +import qualified Reactive.Banana.Test.High.Combinators +import qualified Reactive.Banana.Test.High.Space + +main = defaultMain $ testGroup "reactive-banana" + [ testGroup "Low-level" + [ Reactive.Banana.Test.Low.Graph.tests + , Reactive.Banana.Test.Low.GraphGC.tests + ] + , testGroup "Mid-level" + [ Reactive.Banana.Test.Mid.Space.tests + ] + , testGroup "High-level" + [ Reactive.Banana.Test.High.Combinators.tests + , Reactive.Banana.Test.High.Space.tests + ] + ] diff --git a/test/space.hs b/test/space.hs new file mode 100644 --- /dev/null +++ b/test/space.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns #-} +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +module Main where + +import Control.Monad + ( foldM, void ) + +import qualified Reactive.Banana.Test.Mid.Space as Mid +import qualified Reactive.Banana.Test.High.Space as High + +main :: IO () +main = do + say "Running..." + -- void $ High.runNetworkSizes High.executeAccumE1 [1..20000] + -- void $ High.runNetworkSizes High.switchAccumE1 [1..10000] + -- void $ High.runNetworkSizes High.observeAccumE1 [1..10000] + -- void $ runMidNetwork Mid.executeAccum1 [1..50000] + void $ runMidNetwork Mid.switchAccum1 [1..20000] + say "Done" + +say :: String -> IO () +say = putStrLn + +{----------------------------------------------------------------------------- + Test harness +------------------------------------------------------------------------------} +runMidNetwork f xs = do + (network0, step) <- Mid.compileToStateMachine f + void $ runStrict step xs network0 + +runStrict :: Monad m => (a -> s -> m s) -> [a] -> s -> m s +runStrict f [] !s = pure s +runStrict f (x:xs) !s = runStrict f xs =<< f x s