diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,30 @@ Changelog for the `reactive-banana` package ------------------------------------------- +**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. @@ -8,7 +32,8 @@ * 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 [pqueues][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC. +* 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** @@ -30,7 +55,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** @@ -81,7 +106,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/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/Bug.hs b/doc/examples/Bug.hs deleted file mode 100644 --- a/doc/examples/Bug.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -module RBBug where - -import Reactive.Banana -import Reactive.Banana.Frameworks - -data State = State { stateCounter :: Int } - -test :: Int -> IO () -test n = do - compile $ network n - return () - -network :: Frameworks t => Int -> Moment t () -network 1 = mdo - let state = pure (State 0) -- switchB (pure (State 0)) never - positivityChanges <- changes isPositive - reactimate' (fmap (fmap print) positivityChanges) - let isPositive = fmap ((>= 0) . stateCounter) state - return () -network 2 = mdo - let b = stepper (State 0) e - e <- execute $ (\a -> FrameworksMoment $ return a) <$> (b <@ never) - return () 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.9.0.0 +Version: 1.0.0.0 Synopsis: Library for functional reactive programming (FRP). Description: Reactive-banana is a library for Functional Reactive Programming (FRP). @@ -9,14 +9,13 @@ See the project homepage for more detailed documentation and examples. . - /Stability forecast:/ - . - No semantic bugs expected. - . - Significant API changes are planned for version 1.0. - . - 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. + . + /API guide./ + Start with the "Reactive.Banana" module. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3 @@ -24,13 +23,14 @@ Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus Category: FRP -Cabal-version: >= 1.9.2 +Cabal-version: >= 1.18 Build-type: Simple extra-source-files: CHANGELOG.md, doc/examples/*.hs, src/Reactive/Banana/Test.hs, src/Reactive/Banana/Test/Plumbing.hs +extra-doc-files: doc/*.png Source-repository head type: git @@ -42,9 +42,10 @@ 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 . +-- otherwise it is set to False . Library + default-language: Haskell98 hs-source-dirs: src build-depends: base >= 4.2 && < 5, @@ -61,18 +62,15 @@ 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.Cached other-modules: Control.Monad.Trans.ReaderWriterIO, Control.Monad.Trans.RWSIO, Reactive.Banana.Internal.Combinators, - Reactive.Banana.Internal.Phantom, Reactive.Banana.Prim.Combinators, Reactive.Banana.Prim.Compile, Reactive.Banana.Prim.Dependencies, @@ -87,6 +85,7 @@ Reactive.Banana.Types Test-Suite tests + default-language: Haskell98 type: exitcode-stdio-1.0 hs-source-dirs: src main-is: Reactive/Banana/Test.hs 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 @@ -22,7 +22,7 @@ -- /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 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,44 @@ {----------------------------------------------------------------------------- - 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 @@ -6,21 +6,27 @@ 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 module Control.Applicative, module Data.Monoid, - never, union, unions, filterE, collect, spill, accumE, - apply, stepper, + never, unionWith, filterE, + apply, -- $classes - + + -- ** Moment and accumulation + Moment, MonadMoment(..), + accumE, stepper, + + -- ** Higher-order + valueB, valueBLater, observeE, switchE, switchB, + -- * Derived Combinators -- ** Infix operators (<@>), (<@), @@ -28,9 +34,7 @@ filterJust, filterApply, whenE, split, -- ** Accumulation -- $Accumulation. - accumB, mapAccum, - -- ** Simultaneous event occurrences - calm, unionWith, + unions, accumB, mapAccum, ) where import Control.Applicative @@ -44,195 +48,196 @@ {----------------------------------------------------------------------------- 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 wrap xs) - where - wrap [] = Nothing - wrap xs = Just xs - -toList :: Maybe [a] -> [a] -toList Nothing = [] -toList (Just xs) = xs +interpret :: (Event a -> Event b) -> [Maybe a] -> IO [Maybe b] +interpret f = Prim.interpret (return . unE . f . E) {----------------------------------------------------------------------------- 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) - --- | Merge several event streams of the same type. --- --- > unions = foldr union never -unions :: [Event t a] -> Event t a -unions = foldr union never +-- > 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 e1 e2 = E $ Prim.unionWith f (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: --- --- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])] -collect :: Event t a -> Event t [a] -collect e = E $ Prim.mapE singleton (unE e) - --- | Emit simultaneous event occurrences. --- The first element in the list will be emitted first, and so on. --- --- Up to strictness, we have --- --- > 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 --- --- > 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 - --- | The 'accumE' function accumulates a stream of events. --- 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 lift - - lift f (_,acc) = acc `seq` f acc - - --- 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 - -- | Apply a time-varying function to a stream of events. --- Think of it as --- +-- Semantically, +-- -- > 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) +apply :: Behavior (a -> b) -> Event a -> Event b +apply bf ex = E $ Prim.applyE (unB bf) (unE ex) {-$classes /Further combinators that Haddock can't document properly./ -> instance Applicative (Behavior t) +> instance Applicative Behavior 'Behavior' is an applicative functor. In particular, we have the following functions. -> pure :: a -> Behavior t a +> pure :: a -> Behavior a -The constant time-varying value. Think of it as @pure x = \\time -> x@. +The constant time-varying value. Semantically, @pure x = \\time -> x@. -> (<*>) :: Behavior t (a -> b) -> Behavior t a -> Behavior t b +> (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b Combine behaviors in applicative style. -Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. +The semantics are: @bf \<*\> bx = \\time -> bf time $ bx time@. -} -{- No monoid instance, sorry. - -instance Monoid (Event t (a -> a)) where - mempty = never - mappend = unionWith (flip (.)) --} - -instance Functor (Event t) where - fmap f e = E $ Prim.mapE (map f) (unE e) +instance Functor Event where + fmap f = E . Prim.mapE f . unE -instance Applicative (Behavior t) where +instance Applicative Behavior where pure x = B $ Prim.pureB x bf <*> bx = B $ Prim.applyB (unB bf) (unB bx) -instance Functor (Behavior t) where +instance Functor Behavior where fmap = liftA +-- | Construct a time-varying function from an initial value and +-- a stream of new values. The result will be a step function. +-- Semantically, +-- +-- > stepper x0 ex = \time1 -> \time2 -> +-- > last (x0 : [x | (timex,x) <- ex, time1 <= timex, timex < time2]) +-- +-- Here is an illustration of the result Behavior at a particular time: +-- +-- <> +-- +-- Note: The smaller-than-sign in the comparison @timex < time2@ means +-- that at time @time2 == timex@, the value of the Behavior will +-- still be the previous value. +-- In the illustration, this is indicated by the dots at the end +-- of each step. +-- This allows for recursive definitions. +stepper :: MonadMoment m => a -> Event a -> m (Behavior a) +stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE + +-- | The 'accumE' function accumulates a stream of event values, +-- similar to a /strict/ left scan, 'scanl''. +-- It starts with an initial value and emits a new value +-- whenever an event occurrence happens. +-- The new value is calculated by applying the function in the event +-- to the old value. +-- +-- Example: +-- +-- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] +-- > = trimE [(time1,"xy"),(time2,"xyz")] +-- > where +-- > trimE e start = [(time,x) | (time,x) <- e, start <= time] +-- +-- +-- Note: It makes sense to list the 'accumE' function as a primitive +-- combinator, but keep in mind that it can actually be expressed +-- in terms of 'stepper' and 'apply' by using recursion: +-- +-- > accumE a e1 = mdo +-- > let e2 = (\a f -> f a) <$> b <@> e1 +-- > b <- stepper a e2 +-- > return e2 +-- +accumE :: MonadMoment m => a -> Event (a -> a) -> m (Event a) +accumE acc = liftMoment . M . fmap E . Prim.accumE acc . unE + +-- | Obtain the value of the 'Behavior' at a given moment in time. +-- Semantically, it corresponds to +-- +-- > valueB b = \time -> b time +-- +-- NOTE: The value is immediately available for pattern matching. +-- Unfortunately, this means that @valueB@ is unsuitable for use +-- with value recursion in the 'Moment' monad. +-- If you need recursion, please use 'valueBLater' instead. +valueB :: MonadMoment m => Behavior a -> m a +valueB = liftMoment . M . Prim.valueB . unB + +-- | Obtain the value of the 'Behavior' at a given moment in time. +-- Semantically, it corresponds to +-- +-- > valueBLater b = \time -> b time +-- +-- NOTE: To allow for more recursion, the value is returned /lazily/ +-- and not available for pattern matching immediately. +-- It can be used safely with most combinators like 'stepper'. +-- If that doesn't work for you, please use 'valueB' instead. +valueBLater :: MonadMoment m => Behavior a -> m a +valueBLater = liftMoment . M . Prim.initialBLater . unB + + +-- | Observe a value at those moments in time where +-- event occurrences happen. Semantically, +-- +-- > observeE e = [(time, m time) | (time, m) <- e] +observeE :: Event (Moment a) -> Event a +observeE = E . Prim.observeE . Prim.mapE unM . unE + +-- | Dynamically switch between 'Event'. +-- Semantically, +-- +-- > switchE ee = concat [trim t1 t2 e | (t1,t2,e) <- intervals ee] +-- > where +-- > intervals e = [(time1, time2, x) | ((time1,x),(time2,_)) <- zip e (tail e)] +-- > trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2] + +switchE :: Event (Event a) -> Event a +switchE = E . Prim.switchE . Prim.mapE (unE) . unE + +-- | Dynamically switch between 'Behavior'. +-- Semantically, +-- +-- > switchB b0 eb = \time -> +-- > last (b0 : [b | (time2,b) <- eb, time2 < time]) time + +switchB :: Behavior a -> Event (Behavior a) -> Behavior a +switchB b = B . Prim.switchB (unB b) . Prim.mapE (unB) . unE + {----------------------------------------------------------------------------- Derived Combinators ------------------------------------------------------------------------------} @@ -253,31 +258,31 @@ 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 -- | 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 (Left a) = Just a @@ -285,39 +290,46 @@ fromRight (Left a) = Nothing fromRight (Right b) = Just b --- | Combine simultaneous event occurrences into a single 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) --- | 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)) +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 - e = accumE (undefined,acc) (lift <$> ef) 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,32 +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, + reactimate, Future, reactimate', changes, -- $changes imposeChanges, - FrameworksMoment(..), execute, liftIOLater, + execute, liftIOLater, -- $liftIO module Control.Monad.IO.Class, - + + -- ** Utility functions + -- | This section collects a few convience functions + -- built from the core functions. + newEvent, mapEventIO, newBehavior, + -- * Running event networks EventNetwork, actuate, pause, - - -- * Utilities - -- $utilities - newEvent, - + -- * Internal interpretFrameworks, showNetwork, ) where @@ -41,7 +45,6 @@ import Data.IORef import Reactive.Banana.Combinators import qualified Reactive.Banana.Internal.Combinators as Prim -import Reactive.Banana.Internal.Phantom import Reactive.Banana.Types @@ -61,29 +64,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 @@ -94,12 +97,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 > @@ -115,24 +118,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', @@ -140,7 +143,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 @@ -148,16 +151,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, @@ -166,8 +169,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. @@ -177,49 +180,41 @@ -- -- 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'. -- --- NOTE: To allow for more recursion, the value is returned /lazily/ --- and not available for pattern matching immediately. --- --- If that doesn't work for you, please use 'valueB' instead. -initial :: Behavior t a -> Moment t a -initial = M . Prim.initialBLater . unB +-- This is essentially just an application of the 'stepper' combinator. +fromChanges :: a -> AddHandler a -> MomentIO (Behavior a) +fromChanges initial changes = do + e <- fromAddHandler changes + stepper initial e -- | Output, -- 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 +-- changes when the behavior is a step function, for instance as -- created by 'stepper'. There are no formal guarantees, -- but the idea is that -- --- > changes (stepper x e) = return (calm e) +-- > changes =<< stepper x e = return e -- -- Note: The values of the event will not become available -- until event processing is complete. -- 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 @@ -227,7 +222,7 @@ have the additional 'Future' type, then the following code snippet may be useful: -> plainChanges :: Frameworks t => Behavior t a -> Moment t (Event t a) +> plainChanges :: Behavior a -> MomentIO (Event a) > plainChanges b = do > (e, handle) <- newEvent > eb <- changes b @@ -248,41 +243,25 @@ -- 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 } - -instance Functor FrameworksMoment where - fmap f (FrameworksMoment x) = FrameworksMoment (fmap f x) -instance Applicative FrameworksMoment where - pure x = FrameworksMoment (pure x) - (FrameworksMoment f) <*> (FrameworksMoment x) = FrameworksMoment (f <*> x) -instance Monad FrameworksMoment where - return x = FrameworksMoment (return x) - (FrameworksMoment m) >>= g = FrameworksMoment (m >>= runFrameworksMoment . g) - -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 even do 'IO' actions here, +-- which is useful if you want to register additional event handlers +-- dynamically. +-- However, there is no +-- guarantee about the order in which the actions are executed. +-- If the result 'Event' of this function is garbage collected, +-- it may also happen that the actions are not executed at all. +-- If you want a reliable way to turn events into 'IO' actions +-- use the 'reactimate' and 'reactimate'' functions. +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. @@ -290,17 +269,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 @@ -339,12 +315,61 @@ showNetwork :: EventNetwork -> IO String showNetwork = Prim.showNetwork . unEN + {----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +-- | Build an 'Event' together with an 'IO' action that can +-- fire occurrences of this event. Variant of 'newAddHandler'. +-- +-- This function is mainly useful for passing callback functions +-- inside a 'reactimate'. +newEvent :: MomentIO (Event a, Handler a) +newEvent = do + (addHandler, fire) <- liftIO $ newAddHandler + e <- fromAddHandler addHandler + return (e,fire) + +-- | Build a 'Behavior' together with an 'IO' action that can +-- update this behavior with new values. +-- +-- Implementation: +-- +-- > newBehavior a = do +-- > (e, fire) <- newEvent +-- > b <- stepper a e +-- > return (b, fire) +newBehavior :: a -> MomentIO (Behavior a, Handler a) +newBehavior a = do + (e, fire) <- newEvent + b <- stepper a e + return (b, fire) + +-- | Build a new 'Event' that contains the result +-- of an IO computation. +-- The input and result events will /not/ be simultaneous anymore, +-- the latter will occur /later/ than the former. +-- +-- Please use the 'fmap' for 'Event' if your computation is pure. +-- +-- Implementation: +-- +-- > mapEventIO f e1 = do +-- > (e2, handler) <- newEvent +-- > reactimate $ (\a -> f a >>= handler) <$> e1 +-- > return e2 +mapEventIO :: (a -> IO b) -> Event a -> MomentIO (Event b) +mapEventIO f e1 = do + (e2, handler) <- newEvent + reactimate $ (\a -> f a >>= 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]] +interpretFrameworks :: (Event a -> Event b) -> [a] -> IO [[b]] interpretFrameworks f xs = do output <- newIORef [] (addHandler, runHandlers) <- newAddHandler @@ -362,38 +387,10 @@ -- | 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 -> Event b) -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do network <- compile $ do e <- fromAddHandler addHandlerA reactimate $ handlerB <$> f e 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 --- a/src/Reactive/Banana/Internal/Combinators.hs +++ b/src/Reactive/Banana/Internal/Combinators.hs @@ -100,7 +100,7 @@ e <- liftBuild $ do p <- Prim.unsafeMapIOP (const poll) =<< Prim.alwaysP return $ Prim.fromPure p - return $ stepperB a e + stepperB a e liftIONow :: IO a -> Moment a liftIONow = liftIO @@ -117,28 +117,51 @@ 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 +pureB a = cache $ do + p <- runCached never + return (Prim.pureL a, p) +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 - 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 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) -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) +accumE a e1 = cacheAndSchedule $ do + p0 <- runCached e1 + liftBuild $ do + (_,p1) <- Prim.accumL a p0 + return p1 {----------------------------------------------------------------------------- Combinators - dynamic event switching @@ -156,18 +179,6 @@ initialBLater :: Behavior a -> Moment a initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB -trimE :: Event a -> Moment (Moment (Event a)) -trimE e = do - -- make sure that the event is added to the network eventually - liftBuildFun Prim.buildLater $ void $ runCached e - return $ return $ e - -trimB :: Behavior a -> Moment (Moment (Behavior a)) -trimB b = do - -- make sure that the behavior is added to the network eventually - liftBuildFun Prim.buildLater $ void $ runCached b - return $ return $ b - executeP :: Pulse (Moment a) -> Moment (Pulse a) executeP p1 = do r <- ask @@ -184,15 +195,15 @@ p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e return $ fromPure p -switchE :: Event (Moment (Event a)) -> Event a +switchE :: Event (Event a) -> Event a switchE = liftCached1 $ \p1 -> do - p2 <- liftBuild $ Prim.mapP (runCached =<<) p1 + p2 <- liftBuild $ Prim.mapP (runCached) p1 p3 <- executeP p2 liftBuild $ Prim.switchP p3 -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a +switchB :: Behavior a -> Event (Behavior a) -> Behavior a switchB = liftCached2 $ \(l0,p0) p1 -> do - p2 <- liftBuild $ Prim.mapP (runCached =<<) p1 + p2 <- liftBuild $ Prim.mapP (runCached) p1 p3 <- executeP p2 liftBuild $ do 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 @@ -4,36 +4,36 @@ {-# LANGUAGE BangPatterns #-} module Reactive.Banana.Model ( -- * Synopsis - -- | Model implementation of the abstract syntax tree. - - -- * Description + -- | Model implementation for learning and testing. + + -- * Overview -- $model -- * Combinators -- ** Data types - Event, Behavior, + Time, Event, Behavior, Moment, -- ** Basic never, filterJust, unionWith, mapE, accumE, applyE, stepperB, pureB, applyB, mapB, -- ** Dynamic event switching - Moment, - valueB, trimE, trimB, observeE, switchE, switchB, - + valueB, observeE, switchE, switchB, + -- * Interpretation interpret, ) where import Control.Applicative import Control.Monad (join) +import Data.List (splitAt) {-$model -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.) @@ -42,69 +42,120 @@ Note that 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 + Types ------------------------------------------------------------------------------} -type Event a = [Maybe a] -- should be abstract -data Behavior a = StepperB !a (Event a) -- should be abstract +-- | 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. +-- Details will be explained elsewhere. +type Time = Int +data Event a = E Time [Maybe a] -- starting time, event values (always infinite) + deriving (Show) +data Behavior a = B Time a [a] -- starting time, old value, new values (always infinite) + deriving (Show) +type Moment a = Time -> a -- should be abstract + +epoch :: Time +epoch = 0 + +-- | Set the starting time of an Event. +trimE :: Event a -> Moment (Event a) +trimE (E t xs) s + | s <= t = E s $ replicate (t-s) Nothing ++ xs + | s > t = E s $ drop (s-t) xs + +-- | Set the starting time of an Event. +trimB :: Behavior a -> Moment (Behavior a) +trimB (B t x xs) s + | s <= t = B s x $ replicate (t-s) x ++ xs + | s > t = B s (last ys) zs + where + (ys,zs) = splitAt (s-t) xs + +-- Synchronize two entities +syncEE ~ex@(E tx _) ~ey@(E ty _) = (ex `trimE` t, ey `trimE` t) + where t = min tx ty +syncBE ~bx@(B tx _ _) ~ey@(E ty _) = (bx `trimB` t, ey `trimE` t) + where t = min tx ty +syncBB ~bx@(B tx _ _) ~by@(B ty _ _) = (bx `trimB` t, by `trimB` t) + where t = min tx ty + +{----------------------------------------------------------------------------- + Basic Combinators +------------------------------------------------------------------------------} interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] -interpret f e = f e 0 +interpret f as = zipWith const bs as + where + input = E epoch (as ++ repeat Nothing) + output = f input (epoch-7) `trimE` epoch + E _ bs = output + -- build network before epoch, but start external event at epoch never :: Event a -never = repeat Nothing +never = E epoch (repeat Nothing) filterJust :: Event (Maybe a) -> Event a -filterJust = map join +filterJust (E t xs) = E t (map join xs) unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a -unionWith f = zipWith g +unionWith f ex ey = E t $ zipWith g xs ys where + (E t xs, E _ ys) = syncEE ex ey + 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 -mapE f = applyE (pureB f) +mapE f = applyE (pureB f) applyE :: Behavior (a -> b) -> Event a -> Event b -applyE _ [] = [] -applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs +applyE bf ex = E t $ zipWith (\f x -> fmap f x) (f:fs) xs where - step a (Nothing:b) = stepperB a b - step _ (Just a :b) = stepperB a b - -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) - -stepperB :: a -> Event a -> Behavior a -stepperB = StepperB + (B t f fs, E _ xs) = syncBE bf ex -- applicative functor -pureB x = stepperB x never +pureB x = B epoch x (repeat x) applyB :: Behavior (a -> b) -> Behavior a -> Behavior b -applyB (StepperB f fe) (StepperB x xe) = - stepperB (f x) $ mapE (uncurry ($)) pair +applyB bf bx = B t (f x) $ zipWith ($) fs xs where - pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe) - changeL f (_,x) = (f,x) - changeR x (f,_) = (f,x) + (B t f fs, B _ x xs) = syncBB bf bx mapB f = applyB (pureB f) {----------------------------------------------------------------------------- - Dynamic Event Switching + Accumulation ------------------------------------------------------------------------------} -type Time = Int -type Moment a = Time -> a -- should be abstract +-- Turn first occurence into `Nothing`. +smotherFirst :: Event a -> Event a +smotherFirst (E t (_:xs)) = E t (Nothing:xs) +accumE :: a -> Event (a -> a) -> Moment (Event a) +accumE x e time = E time $ go x xs + where + E _ xs = smotherFirst $ e `trimE` time + + go x (Nothing:fs) = Nothing : go x fs + go x (Just f :fs) = let y = f x in y `seq` (Just y:go y fs) + +stepperB :: a -> Event a -> Moment (Behavior a) +stepperB x e time = B time x $ go x xs + where + E _ xs = smotherFirst $ e `trimE` time + + go x (Nothing:ys) = x : go x ys + go x (Just y :ys) = y : go y ys + +{----------------------------------------------------------------------------- + Dynamic Event Switching +------------------------------------------------------------------------------} {- instance Monad Moment where return = const @@ -112,41 +163,25 @@ -} valueB :: Behavior a -> Moment a -valueB (StepperB x _) = return x - -trimE :: Event a -> Moment (Moment (Event a)) -trimE e = \now -> \later -> drop (later - now) e - -trimB :: Behavior a -> Moment (Moment (Behavior a)) -trimB b = \now -> \later -> bTrimmed !! (later - now) - where - bTrimmed = iterate drop1 b - - drop1 (StepperB x [] ) = StepperB x never - drop1 (StepperB x (Just y :ys)) = StepperB y ys - drop1 (StepperB x (Nothing:ys)) = StepperB x ys +valueB b time = x + where B _ x _ = b `trimB` time observeE :: Event (Moment a) -> Event a -observeE = zipWith (\time -> fmap ($ time)) [0..] - -switchE :: Event (Moment (Event a)) -> Event a -switchE = step never . observeE - 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 +observeE (E t xs) = E t $ zipWith (\time -> fmap ($ time)) [t..] xs -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a -switchB (StepperB x e) = stepperB x . step e . observeE +switchE :: Event (Event a) -> Event a +switchE (E t xs) = E t $ go t (repeat Nothing) xs 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 + go time (y:ys) (Nothing:es) = y : go (time+1) ys es + go time (y:ys) (Just e :es) = y : go (time+1) zs es where - value = case zs of - Just z : _ -> z -- new behavior changes right away - _ -> x -- new behavior stays constant for a while + E _ zs = e `trimE` (time + 1) +switchB :: Behavior a -> Event (Behavior a) -> Behavior a +switchB b x = B t y $ go t ys es + where + (B t y ys, E _ es) = syncBE b x + go time (y:ys) (Nothing:es) = y : go (time+1) ys es + go time _ (Just b :es) = z : go (time+1) zs es + where B _ z zs = b `trimB` (time+1) diff --git a/src/Reactive/Banana/Prim/Cached.hs b/src/Reactive/Banana/Prim/Cached.hs --- a/src/Reactive/Banana/Prim/Cached.hs +++ b/src/Reactive/Banana/Prim/Cached.hs @@ -47,7 +47,7 @@ fromPure :: Monad m => a -> Cached m a fromPure = Cached . return --- | Lift an action that is /not/ chached, for instance because it is idempotent. +-- | 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 diff --git a/src/Reactive/Banana/Prim/Compile.hs b/src/Reactive/Banana/Prim/Compile.hs --- a/src/Reactive/Banana/Prim/Compile.hs +++ b/src/Reactive/Banana/Prim/Compile.hs @@ -36,7 +36,7 @@ let state2 = Network { nTime = next time1 - , nOutputs = foldr OB.insert outputs1 os + , nOutputs = OB.inserts outputs1 os , nAlwaysP = Just theAlwaysP } return (a,state2) diff --git a/src/Reactive/Banana/Prim/Evaluation.hs b/src/Reactive/Banana/Prim/Evaluation.hs --- a/src/Reactive/Banana/Prim/Evaluation.hs +++ b/src/Reactive/Banana/Prim/Evaluation.hs @@ -49,7 +49,7 @@ let actions = OB.inOrder outputs outputs1 -- EvalO actions in proper order state2 = Network { nTime = next time1 - , nOutputs = foldr OB.insert outputs1 os + , nOutputs = OB.inserts outputs1 os , nAlwaysP = Just alwaysP } return (runEvalOs $ map snd actions, state2) diff --git a/src/Reactive/Banana/Prim/OrderedBag.hs b/src/Reactive/Banana/Prim/OrderedBag.hs --- a/src/Reactive/Banana/Prim/OrderedBag.hs +++ b/src/Reactive/Banana/Prim/OrderedBag.hs @@ -9,7 +9,7 @@ import Data.Functor import qualified Data.HashMap.Strict as Map import Data.Hashable -import Data.List +import Data.List hiding (insert) import Data.Maybe import Data.Ord @@ -25,8 +25,16 @@ -- | 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) => a -> OrderedBag a -> OrderedBag a -insert x (OB xs n) = OB (Map.insertWith (\new old -> old) x n xs) (n+1) +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 bag xs = foldl insert bag xs -- | 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. 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,112 +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@. --- --- 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 'initial' instead. -valueB :: Behavior t a -> Moment t a -valueB = M . Prim.valueB . 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 --- a/src/Reactive/Banana/Test.hs +++ b/src/Reactive/Banana/Test.hs @@ -23,36 +23,38 @@ main = defaultMain [ testGroup "Simple" [ testModelMatch "id" id - -- , testModelMatch "never1" never1 + , testModelMatch "never1" never1 , testModelMatch "fmap1" fmap1 , testModelMatch "filter1" filter1 , testModelMatch "filter2" filter2 - , testModelMatch "accumE1" accumE1 + , testModelMatchM "accumE1" accumE1 ] , testGroup "Complex" - [ testModelMatch "counter" counter + [ testModelMatchM "counter" counter , testModelMatch "double" double , testModelMatch "sharing" sharing , testModelMatch "unionFilter" unionFilter - , testModelMatch "recursive1" recursive1 - , testModelMatch "recursive2" recursive2 - , testModelMatch "recursive3" recursive3 - , testModelMatch "recursive4a" recursive4a - , testModelMatch "recursive4b" recursive4b - , testModelMatch "accumBvsE" accumBvsE + , 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 - , testModelMatchM "initialB_immediate" initialB_immediate - -- , testModelMatchM "initialB_recursive1" initialB_recursive1 - -- , testModelMatchM "initialB_recursive2" initialB_recursive2 - , testModelMatchM "trimB_recursive" trimB_recursive + , 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 "switchB_two" switchB_two + , testModelMatch "switchE1" switchE1 + , testModelMatchM "switchB1" switchB1 + , testModelMatchM "switchB2" switchB2 ] , testGroup "Regression tests" - [ testModelMatch "issue79" issue79 + [ testModelMatchM "issue79" issue79 ] -- TODO: -- * algebraic laws @@ -105,8 +107,9 @@ filter2 = filterE (>= 3) . fmap (subtract 1) accumE1 = accumE 0 . ((+1) <$) -counter e = applyE (pure const <*> bcounter) e - where bcounter = accumB 0 $ fmap (\_ -> (+1)) e +counter e = do + bcounter <- accumB 0 $ fmap (\_ -> (+1)) e + return $ applyE (pure const <*> bcounter) e merge e1 e2 = unionWith (++) (list e1) (list e2) where list = fmap (:[]) @@ -120,34 +123,41 @@ e3 = fmap (+1) $ filterE even e1 e2 = fmap (+1) $ filterE odd e1 -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 +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 -> Event Int -recursive3 edec = applyE (const <$> bcounter) ecandecrease - where - bcounter = accumB 4 $ (subtract 1) <$ ecandecrease - ecandecrease = whenE ((>0) <$> bcounter) edec +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 -> Event (Bool, Int) -recursive4a eInput = resultB <@ eInput - where - resultE = resultB <@ eInput - resultB = (,) <$> focus <*> pureB 0 - focus = stepperB False $ fst <$> resultE +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 @@ -156,79 +166,88 @@ 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 +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 -initialB_immediate e = do - x <- valueB (stepper 0 e) +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 can no longer work with 'Build' -being a transformer of the 'IO' monad. -See Note [Recursion]. +{-- The following tests would need to use the valueBLater combinator -initialB_recursive1 e1 = mdo +valueB_recursive1 e1 = mdo _ <- initialB b let b = stepper 0 e1 return $ b <@ e1 -initialB_recursive2 e1 = mdo +valueB_recursive2 e1 = mdo x <- initialB b - let bf = const x <$ stepper 0 e1 + 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 $ (valueB =<< mb) <$ e + b <- stepper 0 e + return $ observeE $ (valueB b) <$ e -- = stepper 0 e <@ e -trimB_recursive e = mdo - let e2 = observeE $ (valueB =<< mb) <$ e - mb <- trimB $ stepper 0 e - return e2 +switchE1 e = switchE (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 +switchB1 e = do + b0 <- stepper 0 e + b1 <- stepper 0 e + let 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 + let b = switchB b0 $ (\x -> if odd x then b1 else b0) <$> e + return $ b <@ e + {----------------------------------------------------------------------------- Regression tests ------------------------------------------------------------------------------} -issue79 :: Event Dummy -> Event String -issue79 inputEvent = outputEvent - where - appliedEvent = (\_ _ -> 1) <$> lastValue <@> inputEvent - filteredEvent = filterE (const True) appliedEvent - fmappedEvent = fmap id (filteredEvent) - lastValue = stepper 1 $ fmappedEvent +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 - outputEvent = unionWith (++) - (const "filtered event" <$> filteredEvent) - (((" and " ++) . show) <$> unionWith (+) appliedEvent fmappedEvent) + let outputEvent = unionWith (++) + (const "filtered event" <$> filteredEvent) + (((" and " ++) . show) <$> unionWith (+) appliedEvent fmappedEvent) + + return $ outputEvent diff --git a/src/Reactive/Banana/Test/Plumbing.hs b/src/Reactive/Banana/Test/Plumbing.hs --- a/src/Reactive/Banana/Test/Plumbing.hs +++ b/src/Reactive/Banana/Test/Plumbing.hs @@ -46,12 +46,9 @@ 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) @@ -65,41 +62,43 @@ (<*>) = ap instance Monad Moment where return a = M (return a) (return a) - (M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g) + ~(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) +accumE a ~(E x y) = M + (fmap ex $ X.accumE a x) + (fmap ey $ Y.accumE a y) +stepperB a ~(E x y) = M + (fmap bx $ X.stepperB a x) + (fmap by $ Y.stepperB a y) +stepper = stepperB + valueB ~(B x y) = M (X.valueB x) (Y.valueB y) observeE :: Event (Moment a) -> Event a observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y) -switchE :: Event (Moment (Event a)) -> Event a +switchE :: Event (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) + (X.switchE $ X.mapE (fstE) x) + (Y.switchE $ Y.mapE (sndE) y) -switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a +switchB :: Behavior a -> Event (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) + (X.switchB x $ X.mapE (fstB) xe) + (Y.switchB y $ Y.mapE (sndB) ye) {----------------------------------------------------------------------------- Derived combinators ------------------------------------------------------------------------------} -accumB acc = stepperB acc . accumE acc +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 <@>, <@ 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 @@ -3,7 +3,9 @@ ------------------------------------------------------------------------------} module Reactive.Banana.Types ( -- | Primitive types. - Event (..), Behavior (..), Moment (..), Future(..) + Event(..), Behavior(..), + Moment(..), MomentIO(..), MonadMoment(..), + Future(..), ) where import Control.Applicative @@ -12,22 +14,30 @@ import Control.Monad.Fix import qualified Reactive.Banana.Internal.Combinators as Prim -import Reactive.Banana.Internal.Phantom -{-| @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, +{-| @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 t a = [(Time,a)] +> 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 +{-| @Behavior a@ represents a value that varies in time. +Semantically, you can think of it as a function -> type Behavior t a = Time -> a +> type Behavior a = Time -> a + +<> -} -newtype Behavior t a = B { unB :: Prim.Behavior a } +newtype Behavior a = B { unB :: Prim.Behavior a } -- | The 'Future' monad is just a helper type for the 'changes' function. -- @@ -46,36 +56,62 @@ pure = F . pure f <*> a = F $ unF f <*> unF a -{-| The 'Moment' monad denotes a value at a particular /moment in time/. +{-| The 'Moment' monad denotes a /pure/ computation that happens +at one particular moment in time. Semantically, it as a reader monad -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. +> type Moment a = Time -> a -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. +When run, the argument tells the time at which this computation happens. -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@. +Note that in this context, /time/ really means to /logical time/. +Of course, every calculation on a computer takes some +amount of wall-clock time to complete. +Instead, what is meant here is the time as it relates to +'Event's and 'Behavior's. +We use the fiction that every calculation within the 'Moment' +monad takes zero /logical time/ to perform. +-} +newtype Moment a = M { unM :: Prim.Moment a } +{-| The 'MomentIO' monad is used to add inputs and outputs +to an event network. -} -newtype Moment t a = M { unM :: Prim.Moment a } +newtype MomentIO a = MIO { unMIO :: Prim.Moment a } --- boilerplate class instances -instance Functor (Moment t) where fmap f = M . fmap f . unM +instance MonadIO MomentIO where liftIO = MIO . liftIO -instance Monad (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 Monad m => MonadMoment m where + liftMoment :: Moment a -> m a + +instance MonadMoment Moment where liftMoment = id +instance MonadMoment MomentIO where liftMoment = MIO . unM + +-- boilerplate class instances +instance Functor Moment where fmap f = M . fmap f . unM +instance Monad Moment where return = M . return m >>= g = M $ unM m >>= unM . g - -instance Applicative (Moment t) where +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 Functor MomentIO where fmap f = MIO . fmap f . unMIO +instance Monad MomentIO where + return = MIO . return + m >>= g = MIO $ unMIO m >>= unMIO . g +instance Applicative MomentIO where + pure = MIO . pure + f <*> a = MIO $ unMIO f <*> unMIO a +instance MonadFix MomentIO where mfix f = MIO $ mfix (unMIO . f) -instance Frameworks t => MonadIO (Moment t) where + +{- +instance Frameworks t => MonadIO Moment where liftIO = M . Prim.liftIONow +-}