reactive-banana 0.7.1.3 → 0.8.0.0
raw patch · 33 files changed
+1902/−1198 lines, 33 filesdep +pqueue
Dependencies added: pqueue
Files
- CHANGELOG.md +87/−0
- doc/examples/SlotMachine.hs +2/−1
- reactive-banana.cabal +37/−26
- src/Control/Event/Handler.hs +74/−0
- src/Reactive/Banana.hs +1/−1
- src/Reactive/Banana/Combinators.hs +25/−39
- src/Reactive/Banana/Experimental/Calm.hs +8/−3
- src/Reactive/Banana/Frameworks.hs +54/−34
- src/Reactive/Banana/Frameworks/AddHandler.hs +0/−55
- src/Reactive/Banana/Internal/Cached.hs +0/−72
- src/Reactive/Banana/Internal/Combinators.hs +210/−0
- src/Reactive/Banana/Internal/DependencyGraph.hs +0/−80
- src/Reactive/Banana/Internal/EventBehavior1.hs +0/−172
- src/Reactive/Banana/Internal/InputOutput.hs +0/−71
- src/Reactive/Banana/Internal/PulseLatch0.hs +0/−566
- src/Reactive/Banana/Internal/Types2.hs +0/−63
- src/Reactive/Banana/Model.hs +3/−2
- src/Reactive/Banana/Prim.hs +42/−0
- src/Reactive/Banana/Prim/Cached.hs +72/−0
- src/Reactive/Banana/Prim/Combinators.hs +191/−0
- src/Reactive/Banana/Prim/Compile.hs +83/−0
- src/Reactive/Banana/Prim/Dated.hs +106/−0
- src/Reactive/Banana/Prim/Dependencies.hs +170/−0
- src/Reactive/Banana/Prim/Evaluation.hs +75/−0
- src/Reactive/Banana/Prim/IO.hs +51/−0
- src/Reactive/Banana/Prim/Order.hs +90/−0
- src/Reactive/Banana/Prim/Plumbing.hs +163/−0
- src/Reactive/Banana/Prim/Test.hs +37/−0
- src/Reactive/Banana/Prim/Types.hs +194/−0
- src/Reactive/Banana/Switch.hs +3/−3
- src/Reactive/Banana/Test.hs +39/−7
- src/Reactive/Banana/Test/Plumbing.hs +5/−3
- src/Reactive/Banana/Types.hs +80/−0
+ CHANGELOG.md view
@@ -0,0 +1,87 @@+Changelog for the `reactive-banana` package+-------------------------------------------++**version 0.8.0.0**++* A new module `Reactive.Banana.Prim` exports primitive combinators that you can use to implement your own FRP library with a different API.+* The push-driven implementation in `Reactive.Banana.Prim` now has the performance characteristics of an actual push-driven implementation. Some work has gone into optimizing constant factors as well. However there is still no garbage collection for dynamically created events and behaviors.+* The `accumE` and `accumB` combinators evaluate their state to WHNF to avoid a space leak. (Fixes issue #52). On the other hand, `Behavior` values are evaluated on demanded, i.e. only when required by the apply combinator `<@>` or similar.+* Recursion between events and behaviors should now work as advertised. (Fixed issue #56).+* The deprecated `liftIONow` function has been removed.+* The type of the `changes` function now indicates that the new Behavior value is only available in the context of `reactimate`. A variant `reactimate'` makes this explicit.+* The module `Control.Event.Handler` now exports the `AddHandler` type, which is now a `newtype`. The module `Reactive.Banana.Frameworks.AddHandler` has been removed.++**version 0.7.1.0**++* Deprecate the `liftIONow` function in favor of `liftIO`.++**version 0.7.0.0**++* *Dynamic event switching*. Combinators are now available in the module `Reactive.Banana.Switch`.+* Rename `NetworkDescription` to `Moment`, add class constraint `Frameworks t`.+* No longer compiles with the JavaScript backend of the Utrecht Haskell compiler.+* Change the `changes` combinator to be less useful.++**version 0.6.0.0**++* Can now be compiled with the JavaScript backend of the Utrecht Haskell compiler.+* The push-driven implementations needs the `UseExtensions` flag to work. This flag is enabled by default.+* Minor module reorganization.++**version 0.5.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2012/03/25-frp-banana-0-5.html)++This update includes numerous changes, in particular a complete overhaul of the internal implementation. Here a partial list.++* Add `collect`, `spill` and `unionWith` combinators to deal with simultaneous events.+* Remove general `Monoid` instance for `Event` to simplify reasoning about simultaneous events.+* Add `initial` and `changes` combinators that allow you to observe updates to `Behavior`. Remove the `Reactive.Banana.Incremental` module.+* Rename most modules,+* Change type singaturs: The main types `Event`, `Behavior` and `NetworkDescription` now carry an additional phantom type.++**version 0.4.3.1**++* Model implementation of `accumE` now has the intended semantics.++**version 0.4.3.0**++* Change semantics: `IO` actions from inside `reactimate` may now interleave as dictated by your event-based framework (issue #15).+* Fix bug: compiling a network twice no longer fails due to lingering global state (issue #16).+* Change type: remove `Typeable` constraint from `interpret` and `interpretAsHandler`.+* Misc: Remove the `BlackBoard` application from the repository.++**version 0.4.2.0**++* Change type: remove `Typeable` constraint from `fromAddHandler`.+* Misc: the `Vault` data type gets its own package.+* Misc: `reactive-banana-wx` now compiles properly with cabal.+* Add some more examples to the `reactive-banana-wx` package.++**version 0.4.1.0**++* Add `<@>` operator for more convenience when using `apply`.+* Add support for value recursion to the `NetworkDescription` monad.+* Add many examples to `reactive-banana-wx`.++**version 0.4.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/07/07-frp-banana-0-4.html)++* Add function `fromPoll` to obtain behaviors from mutable data.+* Change name: `run` is now called `actuate`.+* Add derived data type `Discrete`.+* Add function `interpretAsHandler`.++**version 0.3.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-3.html)++* change: event networks are now first-class values, you can `pause` or `run` them.+* change type: `AddHandler` now expects a way to unregister event handlers.+* add example `RunPause.hs`++**version 0.2.0.0** -- [announcement](http://apfelmus.nfshost.com/blog/2011/06/22-frp-banana-0-2.html)++* change: now implements proper semantics as pioneered by Conal Elliott+* model implementation for semantics+* push-driven implementation for efficiency+* add example `SlotMachine.hs`++**version 0.1.0.0**++* initial release
doc/examples/SlotMachine.hs view
@@ -89,7 +89,7 @@ (EventSource (), EventSource ()) -> Moment t () setupNetwork (escoin,esplay) = do -- initial random number generator- initialStdGen <- liftIONow $ newStdGen+ initialStdGen <- liftIO $ newStdGen -- Obtain events corresponding to the coin and play commands ecoin <- fromAddHandler (addHandler escoin)@@ -151,6 +151,7 @@ | otherwise = Nothing + -- ecredits <- changes bcredits reactimate $ putStrLn . showCredit <$> ecredits reactimate $ putStrLn . showRoll <$> eroll reactimate $ putStrLn . showWin <$> ewin
reactive-banana.cabal view
@@ -1,33 +1,39 @@ Name: reactive-banana-Version: 0.7.1.3-Synopsis: Practical library for functional reactive programming (FRP).-Description: - Reactive-banana is a practical library for Functional Reactive Programming (FRP).+Version: 0.8.0.0+Synopsis: Library for functional reactive programming (FRP).+Description:+ Reactive-banana is a library for Functional Reactive Programming (FRP). .- FRP offers an elegant and concise way to express interactive programs such as graphical user interfaces, animations, computer music or robot controllers. Thus, the reactive-banana library promises to avoid the spaghetti code commonly used in traditional GUI technologies.+ FRP offers an elegant and concise way to express interactive programs such as graphical user interfaces, animations, computer music or robot controllers. It promises to avoid the spaghetti code that is all too common in traditional approaches to GUI programming. . See the project homepage <http://haskell.org/haskellwiki/Reactive-banana>- for a more detailed introduction and features.+ for more detailed documentation and examples. .- Stability forecast:+ /Stability forecast:/+ . No semantic bugs expected.+ . Significant API changes are likely in future versions, though the main interface is beginning to stabilize.- The @Reactive.Banana.Switch@ module is quite experimental.- There is currently /no/ garbage collection for dynamically created events.+ .+ The library 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@. Homepage: http://haskell.org/haskellwiki/Reactive-banana License: BSD3 License-file: LICENSE Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus <apfelmus quantentunnel de>-Stability: Experimental Category: FRP Cabal-version: >= 1.9.2 Build-type: Simple -extra-source-files: doc/examples/*.hs,- src/Reactive/Banana/Test.hs+extra-source-files: CHANGELOG.md,+ doc/examples/*.hs,+ src/Reactive/Banana/Test.hs, src/Reactive/Banana/Test/Plumbing.hs Source-repository head@@ -60,30 +66,37 @@ BangPatterns build-depends: unordered-containers >= 0.2.1.0 && < 0.3,- hashable >= 1.1 && < 1.3+ hashable >= 1.1 && < 1.3,+ pqueue >= 1.0 && < 1.3 -- CPP-options: -DUseExtensions exposed-modules:+ Control.Event.Handler, Reactive.Banana, Reactive.Banana.Combinators, Reactive.Banana.Experimental.Calm, Reactive.Banana.Frameworks,- Reactive.Banana.Frameworks.AddHandler,- Reactive.Banana.Model+ Reactive.Banana.Model,+ Reactive.Banana.Prim,+ Reactive.Banana.Prim.Cached, Reactive.Banana.Switch other-modules:- Reactive.Banana.Internal.Cached,- Reactive.Banana.Internal.DependencyGraph,- Reactive.Banana.Internal.EventBehavior1,- Reactive.Banana.Internal.InputOutput+ Reactive.Banana.Internal.Combinators, Reactive.Banana.Internal.Phantom,- Reactive.Banana.Internal.PulseLatch0,- Reactive.Banana.Internal.Types2-+ 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,+ Reactive.Banana.Types --- compiling the test suite from cabal currently doesn't work Test-Suite tests type: exitcode-stdio-1.0 hs-source-dirs: src@@ -93,6 +106,4 @@ test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, reactive-banana, vault, containers, transformers,- unordered-containers, hashable--+ unordered-containers, hashable, pqueue
+ src/Control/Event/Handler.hs view
@@ -0,0 +1,74 @@+module Control.Event.Handler (+ -- * Synopsis+ -- | <http://en.wikipedia.org/wiki/Event-driven_programming Event-driven programming>+ -- in the traditional imperative style.+ + -- * Documentation+ Handler, AddHandler(..), newAddHandler,+ mapIO, filterIO,+ ) where+++import Data.IORef+import qualified Data.Map as Map+import qualified Data.Unique++type Map = Map.Map++{-----------------------------------------------------------------------------+ Types+------------------------------------------------------------------------------}+-- | An /event handler/ is a function that takes an+-- /event value/ and performs some computation.+type Handler a = a -> IO ()++-- | A value of type @Addhandler a@ is a facility for registering+-- event handlers. These will be called whenever the event occurs.+-- +-- When registering an event handler, you will also be given an action+-- that unregisters this handler again.+-- +-- > do unregisterMyHandler <- register addHandler myHandler+--+newtype AddHandler a = AddHandler { register :: Handler a -> IO (IO ()) }++{-----------------------------------------------------------------------------+ Combinators+------------------------------------------------------------------------------}+instance Functor AddHandler where+ fmap f = mapIO (return . f)++-- | Map the event value with an 'IO' action.+mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b+mapIO f e = AddHandler $ \h -> register e $ \x -> f x >>= 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 ()++{-----------------------------------------------------------------------------+ Construction+------------------------------------------------------------------------------}+-- | Build a facility to register and unregister event handlers.+-- Also yields a function that takes an event handler and runs all the registered+-- handlers.+--+-- Example:+--+-- > do+-- > (addHandler, fire) <- newAddHandler+-- > register addHandler putStrLn+-- > fire "Hello!"+newAddHandler :: IO (AddHandler a, Handler a)+newAddHandler = do+ handlers <- newIORef Map.empty+ let register handler = do+ key <- Data.Unique.newUnique+ atomicModifyIORef_ handlers $ Map.insert key handler+ return $ atomicModifyIORef_ handlers $ Map.delete key+ runHandlers a =+ mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers+ return (AddHandler register, runHandlers)++atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())
src/Reactive/Banana.hs view
@@ -12,5 +12,5 @@ import Reactive.Banana.Combinators import Reactive.Banana.Frameworks-import Reactive.Banana.Internal.Types2+import Reactive.Banana.Types import Reactive.Banana.Switch
src/Reactive/Banana/Combinators.hs view
@@ -22,6 +22,8 @@ -- $classes -- * Derived Combinators+ -- ** Infix operators+ (<@>), (<@), -- ** Filtering filterJust, filterApply, whenE, split, -- ** Accumulation@@ -29,20 +31,15 @@ accumB, mapAccum, -- ** Simultaneous event occurrences calm, unionWith,- -- ** Apply class- Apply(..), ) where import Control.Applicative import Control.Monad--import Data.Maybe (isJust, catMaybes)-import Data.Monoid (Monoid(..))---import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2 +import Data.Maybe (isJust, catMaybes)+import Data.Monoid (Monoid(..)) +import qualified Reactive.Banana.Internal.Combinators as Prim+import Reactive.Banana.Types {----------------------------------------------------------------------------- Introduction@@ -81,7 +78,6 @@ interpret f xs = map toList <$> Prim.interpret (return . unE . f . E) (map Just xs) - toList :: Maybe [a] -> [a] toList Nothing = [] toList (Just xs) = xs@@ -190,6 +186,8 @@ -- 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) @@ -197,14 +195,6 @@ /Further combinators that Haddock can't document properly./ -> instance Monoid (Event t (a -> a))--This monoid instance is /not/ the straightforward instance-that you would obtain from 'never' and 'union'.-Instead of just merging event streams, we use 'unionWith' to compose-the functions. This is very useful in the context of 'accumE' and 'accumB'-where simultaneous event occurrences are best avoided.- > instance Applicative (Behavior t) 'Behavior' is an applicative functor. In particular, we have the following functions.@@ -254,7 +244,20 @@ signum = fmap signum fromInteger = pure . fromInteger -}+infixl 4 <@>, <@ +-- | Infix synonym for the 'apply' combinator. Similar to '<*>'.+-- +-- > infixl 4 <@>+(<@>) :: Behavior t (a -> b) -> Event t a -> Event t 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 + -- | 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@@ -276,7 +279,6 @@ 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)@@ -288,11 +290,11 @@ calm :: Event t a -> Event t a calm = fmap last . collect -- -- $Accumulation.--- Note: all accumulation functions are strict in the accumulated value!--- acc -> (x,acc) is the order used by 'unfoldr' and 'State'.+-- 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.@@ -311,20 +313,4 @@ 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)---infixl 4 <@>, <@---- | Class for overloading the 'apply' function.-class (Functor f, Functor g) => Apply f g where- -- | Infix operation for the 'apply' function, similar to '<*>'- (<@>) :: f (a -> b) -> g a -> g b- -- | Convenience function, similar to '<*'- (<@) :: f a -> g b -> g a- - f <@ g = (const <$> f) <@> g --instance Apply (Behavior t) (Event t) where- (<@>) = apply-
src/Reactive/Banana/Experimental/Calm.hs view
@@ -29,7 +29,7 @@ -- $Accumulation. accumB, mapAccum, -- ** Apply class- Reactive.Banana.Combinators.Apply(..),+ (<@>), (<@), ) where import Control.Applicative@@ -119,7 +119,12 @@ 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) -instance Reactive.Banana.Combinators.Apply (Behavior t) (Event t) where- (<@>) = apply+-- | 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
src/Reactive/Banana/Frameworks.hs view
@@ -14,9 +14,10 @@ -- * Building event networks with input/output -- $build compile, Frameworks,- AddHandler, fromAddHandler, fromChanges, fromPoll,- reactimate, initial, changes,- FrameworksMoment(..), execute, liftIOLater, liftIONow,+ module Control.Event.Handler,+ fromAddHandler, fromChanges, fromPoll,+ reactimate, reactimate', initial, changes, imposeChanges,+ FrameworksMoment(..), execute, liftIOLater, -- $liftIO module Control.Monad.IO.Class, @@ -25,24 +26,22 @@ -- * Utilities -- $utilities- newAddHandler, newEvent,- module Reactive.Banana.Frameworks.AddHandler,+ newEvent, -- * Internal- interpretFrameworks,+ interpretFrameworks, showNetwork, ) where -import Control.Monad-import Control.Monad.IO.Class-import Data.IORef+import Control.Event.Handler+import Control.Monad+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 Reactive.Banana.Types -import Reactive.Banana.Combinators-import Reactive.Banana.Frameworks.AddHandler -import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2-import Reactive.Banana.Internal.Phantom- {----------------------------------------------------------------------------- Documentation ------------------------------------------------------------------------------}@@ -147,8 +146,17 @@ -} reactimate :: Frameworks t => Event t (IO ()) -> Moment t ()-reactimate = M . Prim.addReactimate . Prim.mapE sequence_ . unE+reactimate = M . Prim.addReactimate . Prim.mapE (return . sequence_) . 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++ -- | Input, -- obtain an 'Event' from an 'AddHandler'. --@@ -181,6 +189,11 @@ 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++-- | Output, -- observe when a 'Behavior' changes. -- -- Strictly speaking, a 'Behavior' denotes a value that@@ -194,18 +207,21 @@ -- -- > changes (stepper x e) = return (calm e) ----- WARNING: The values of the event will not become available--- until event processing is complete. Use them within 'reactimate'.--- If you try to access them before that, the program--- will be thrown into an infinite loop.-changes :: Frameworks t => Behavior t a -> Moment t (Event t a)-changes = return . singletonsE . Prim.changesB . unB---- | Output,--- observe the initial value contained in a 'Behavior'.-initial :: Behavior t a -> Moment t a-initial = M . Prim.initialB . unB+-- 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 +-- | Impose a different sampling event on a 'Behavior'.+--+-- The 'Behavior' will vary continuously 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 b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e)) -- | Dummy type needed to simulate impredicative polymorphism. newtype FrameworksMoment a@@ -234,11 +250,6 @@ -- -- Lift an 'IO' action into the 'Moment' monad. -{-# DEPRECATED liftIONow "Use liftIO instead." #-}--- | Deprecated. Use 'liftIO' instead.-liftIONow :: Frameworks t => IO a -> Moment t a-liftIONow = liftIO- -- | Lift an 'IO' action into the 'Moment' monad, -- but defer its execution until compilation time. -- This can be useful for recursive definitions using 'MonadFix'.@@ -282,6 +293,15 @@ pause :: EventNetwork -> IO () pause = Prim.pause . unEN +-- | A multiline description of the current 'Latch'es and 'Pulse's in+-- the 'EventNetwork'.+--+-- 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+ {----------------------------------------------------------------------------- Simple use ------------------------------------------------------------------------------}@@ -308,7 +328,7 @@ interpretAsHandler :: (forall t. Event t a -> Event t b) -> AddHandler a -> AddHandler b-interpretAsHandler f addHandlerA = \handlerB -> do+interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do network <- compile $ do e <- fromAddHandler addHandlerA reactimate $ handlerB <$> f e@@ -335,7 +355,7 @@ -- -- This function is mainly useful for passing callback functions -- inside a 'reactimate'.-newEvent :: Frameworks t => Moment t (Event t a, a -> IO ())+newEvent :: Frameworks t => Moment t (Event t a, Handler a) newEvent = do (addHandler, fire) <- liftIO $ newAddHandler e <- fromAddHandler addHandler
− src/Reactive/Banana/Frameworks/AddHandler.hs
@@ -1,55 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Frameworks.AddHandler (- -- * Synopsis- -- | Various utility functions concerning event handlers.- - -- * Documentation- AddHandler, newAddHandler,- mapIO, filterAddHandler,- ) where---import Data.IORef-import qualified Data.Unique -- ordinary uniques here, because they are Ord--import qualified Data.Map as Map--type Map = Map.Map--{------------------------------------------------------------------------------ AddHandler-------------------------------------------------------------------------------}--- | A value of type @AddHandler a@ is just a facility for registering--- callback functions, also known as event handlers.--- --- The type is a bit mysterious, it works like this:--- --- > do unregisterMyHandler <- addHandler myHandler------ The argument is an event handler that will be registered.--- The return value is an action that unregisters this very event handler again.-type AddHandler a = (a -> IO ()) -> IO (IO ())---- | Apply a function with side effects to an 'AddHandler'-mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b-mapIO f addHandler = \h -> addHandler $ \x -> f x >>= h ---- | Filter event occurrences that don't return 'True'.-filterAddHandler :: (a -> IO Bool) -> AddHandler a -> AddHandler a-filterAddHandler f addHandler = \h ->- addHandler $ \x -> f x >>= \b -> if b then h x else return ()---- | Build a facility to register and unregister event handlers.-newAddHandler :: IO (AddHandler a, a -> IO ())-newAddHandler = do- handlers <- newIORef Map.empty- let addHandler k = do- key <- Data.Unique.newUnique- modifyIORef handlers $ Map.insert key k- return $ modifyIORef handlers $ Map.delete key- runHandlers x =- mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers- return (addHandler, runHandlers)-
− src/Reactive/Banana/Internal/Cached.hs
@@ -1,72 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Internal.Cached (- -- | Utility for executing monadic actions once- -- and then retrieving values from a cache.- -- - -- Very useful for observable sharing.- HasVault(..),- Cached, runCached, mkCached, fromPure,- liftCached1, liftCached2,- ) where--import Control.Monad-import Control.Monad.Fix-import Data.Unique.Really-import qualified Data.Vault.Lazy as Vault-import System.IO.Unsafe--{------------------------------------------------------------------------------ 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 'Vault' that can be used.-class (Monad m, MonadFix m) => HasVault m where- retrieve :: Vault.Key a -> m (Maybe a)- write :: Vault.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 mkCached #-}-mkCached :: HasVault m => m a -> Cached m a-mkCached m = unsafePerformIO $ do- key <- Vault.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 'Vault'.-fromPure :: HasVault m => a -> Cached m a-fromPure = Cached . return--liftCached1- :: HasVault m- => (a -> m b)- -> Cached m a -> Cached m b-liftCached1 f ca = mkCached $ do- a <- runCached ca- f a--liftCached2- :: HasVault m- => (a -> b -> m c)- -> Cached m a -> Cached m b -> Cached m c-liftCached2 f ca cb = mkCached $ do- a <- runCached ca- b <- runCached cb- f a b-
+ src/Reactive/Banana/Internal/Combinators.hs view
@@ -0,0 +1,210 @@+{-----------------------------------------------------------------------------+ 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 (\_ _ -> ())
− src/Reactive/Banana/Internal/DependencyGraph.hs
@@ -1,80 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.DependencyGraph (- -- | Utilities for operating with dependency graphs.- Deps,- empty, dependOn, topologicalSort, - ) where--import Data.Hashable-import qualified Data.HashMap.Lazy as Map-import qualified Data.HashSet as Set--type Map = Map.HashMap-type Set = Set.HashSet--{------------------------------------------------------------------------------ Dependency graph data type-------------------------------------------------------------------------------}--- dependency graph-data Deps a = Deps- { dChildren :: Map a [a] -- children depend on their parents- , dParents :: Map a [a]- , dRoots :: Set a- } deriving (Show)---- convenient queries-children deps x = maybe [] id . Map.lookup x $ dChildren deps-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- , dRoots = Set.empty- }--{------------------------------------------------------------------------------ Operations-------------------------------------------------------------------------------}--- add a dependency to the graph-dependOn :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a-dependOn x y deps0 = deps1- where- deps1 = deps0- { dChildren = Map.insertWith (++) y [x] $ dChildren deps0- , dParents = Map.insertWith (++) x [y] $ dParents deps0- , dRoots = roots- }- - roots = when (null $ parents deps0 x) (Set.delete x)- . when (null $ parents deps1 y) (Set.insert y)- $ dRoots deps0- - when b f = if b then f else id---- order the nodes in a way such that no children comes before its parent-topologicalSort :: (Eq a, Hashable a) => Deps a -> [a]-topologicalSort deps = go (Set.toList $ dRoots deps) Set.empty- where- go [] _ = []- go (x:xs) seen1 = x : go (adultChildren ++ xs) seen2- where- seen2 = Set.insert x seen1- adultChildren = filter isAdult (children deps x)- isAdult y = all (`Set.member` seen2) (parents deps y)--{------------------------------------------------------------------------------ Small tests-------------------------------------------------------------------------------}-test = id- . dependOn 'D' 'C'- . dependOn 'D' 'B'- . dependOn 'C' 'B'- . dependOn 'B' 'A'- . dependOn 'B' 'a'- $ empty--
− src/Reactive/Banana/Internal/EventBehavior1.hs
@@ -1,172 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}-module Reactive.Banana.Internal.EventBehavior1 (- -- * Interpreter- interpret, compile,- - -- * Basic combinators- Event, Behavior,- never, filterJust, unionWith, mapE, accumE, applyE,- changesB, stepperB, pureB, applyB, mapB,- - -- * Dynamic event switching- Moment,- initialB, trimE, trimB, executeE, observeE, switchE, switchB,- - -- * Setup and IO- addReactimate, fromAddHandler, fromPoll, liftIONow, liftIOLater,- EventNetwork, pause, actuate,- ) where--import Data.Functor-import Data.Functor.Identity-import Control.Monad (join, (<=<))-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class (lift)--import qualified Reactive.Banana.Internal.PulseLatch0 as Prim-import Reactive.Banana.Internal.Cached-import Reactive.Banana.Internal.InputOutput-import Reactive.Banana.Frameworks.AddHandler--type Network = Prim.Network-type Latch = Prim.Latch-type Pulse = Prim.Pulse--{------------------------------------------------------------------------------ Types-------------------------------------------------------------------------------}-type Behavior a = Cached Network (Latch a, Pulse ())-type Event a = Cached Network (Pulse a)-type Moment = Prim.NetworkSetup--runCachedM :: Cached Network a -> Moment a-runCachedM = Prim.liftNetwork . runCached--{------------------------------------------------------------------------------ Interpretation-------------------------------------------------------------------------------}-inputE :: InputChannel a -> Event a-inputE = mkCached . Prim.inputP--interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret (\pulse -> runCachedM =<< f (fromPure pulse))--compile :: Moment () -> IO EventNetwork-compile = Prim.compile--{------------------------------------------------------------------------------ Combinators - basic-------------------------------------------------------------------------------}-never = mkCached $ Prim.neverP-unionWith f = liftCached2 $ Prim.unionWith f-filterJust = liftCached1 $ Prim.filterJustP-accumE x = liftCached1 $ Prim.accumP x-mapE f = liftCached1 $ Prim.mapP f-applyE = liftCached2 $ \(lf,_) px -> Prim.applyP lf px--changesB = liftCached1 $ \(lx,px) -> Prim.tagFuture lx px---- Note: To enable more recursion,--- first create the latch and then create the event that is accumulated-stepperB a = \c1 -> mkCached $ mdo- l <- Prim.stepperL a p1- p1 <- runCached c1- p2 <- Prim.mapP (const ()) p1- return (l,p2)--pureB a = stepperB a never-applyB = liftCached2 $ \(l1,p1) (l2,p2) -> do- p3 <- Prim.unionWith const p1 p2- l3 <- Prim.applyL l1 l2- return (l3,p3)-mapB f = applyB (pureB f)--{------------------------------------------------------------------------------ Combinators - dynamic event switching-------------------------------------------------------------------------------}-initialB :: Behavior a -> Moment a-initialB b = Prim.liftNetwork $ do- ~(l,_) <- runCached b- Prim.valueL l--trimE :: Event a -> Moment (Moment (Event a))-trimE e = do- p <- runCachedM 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) <- runCachedM b -- add behavior to network- return $ return $ fromPure (l,p) -- remember it henceforth---observeE :: Event (Moment a) -> Event a -observeE = liftCached1 $ Prim.executeP--executeE :: Event (Moment a) -> Moment (Event a)-executeE e = Prim.liftNetwork $ do- p <- runCached e- result <- Prim.executeP p- return $ fromPure result--switchE :: Event (Moment (Event a)) -> Event a-switchE = liftCached1 $ \p1 -> do- p2 <- Prim.mapP (runCachedM =<<) p1- p3 <- Prim.executeP p2- Prim.switchP p3--switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a-switchB = liftCached2 $ \(l0,p0) p1 -> do- p2 <- Prim.mapP (runCachedM =<<) p1- p3 <- Prim.executeP p2- 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.unionWith (\_ _ -> ())--{------------------------------------------------------------------------------ Combinators - Setup and IO-------------------------------------------------------------------------------}-addReactimate :: Event (IO ()) -> Moment ()-addReactimate e = do- p <- runCachedM e- lift $ Prim.addReactimate p--liftIONow :: IO a -> Moment a-liftIONow = liftIO--liftIOLater :: IO () -> Moment ()-liftIOLater = lift . Prim.liftIOLater--fromAddHandler :: AddHandler a -> Moment (Event a)-fromAddHandler addHandler = do- i <- liftIO newInputChannel- p <- Prim.liftNetwork $ Prim.inputP i- lift $ Prim.registerHandler $ mapIO (return . (:[]) . toValue i) addHandler- return $ fromPure p--fromPoll :: IO a -> Moment (Behavior a)-fromPoll poll = do- a <- liftIO poll- e <- Prim.liftNetwork $ do- pm <- Prim.mapP (const $ liftIO poll) Prim.alwaysP- p <- Prim.executeP pm- return $ fromPure p- return $ stepperB a e--type EventNetwork = Prim.EventNetwork-pause = Prim.pause-actuate = Prim.actuate
− src/Reactive/Banana/Internal/InputOutput.hs
@@ -1,71 +0,0 @@-{------------------------------------------------------------------------------ Reactive Banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.InputOutput (- -- * Synopsis- -- | Manage the input and output of event graphs.- - -- * Input- -- | Utilities for managing heterogenous input values.- Channel, InputChannel, InputValue,- - newInputChannel, getChannel,- fromValue, toValue,- - -- * Output- -- | Stepwise execution of an event graph.- Automaton(..), fromStateful, unfoldAutomaton,-- ) where--import Control.Applicative-import Control.Exception (evaluate)--import Data.Unique.Really-import qualified Data.Vault.Lazy as Vault--{------------------------------------------------------------------------------ Storing heterogenous input values-------------------------------------------------------------------------------}-type Channel = Unique -- identifies an input-type Key = Vault.Key -- key to retrieve a value-type Value = Vault.Vault -- value storage--data InputChannel a = InputChannel { getChannelC :: Channel, getKey :: Key a }-data InputValue = InputValue { getChannelV :: Channel, getValue :: Value }--newInputChannel :: IO (InputChannel a)-newInputChannel = InputChannel <$> newUnique <*> Vault.newKey--fromValue :: InputChannel a -> InputValue -> Maybe a-fromValue i v = Vault.lookup (getKey i) (getValue v)--toValue :: InputChannel a -> a -> InputValue-toValue i a = InputValue (getChannelC i) $ Vault.insert (getKey i) a Vault.empty---- convenience class for overloading-class HasChannel a where- getChannel :: a -> Channel-instance HasChannel (InputChannel a) where getChannel = getChannelC-instance HasChannel (InputValue) where getChannel = getChannelV---{------------------------------------------------------------------------------ Stepwise execution-------------------------------------------------------------------------------}--- Automaton that takes input values and produces a result-data Automaton a = Step { runStep :: [InputValue] -> IO (Maybe a, Automaton a) }--fromStateful :: ([InputValue] -> s -> IO (Maybe a,s)) -> s -> Automaton a-fromStateful f s = Step $ \i -> do- (a,s') <- f i s- return (a, fromStateful f s')---- | Apply an automaton to a list of input values-unfoldAutomaton :: Automaton b -> InputChannel a -> [Maybe a] -> IO [Maybe b]-unfoldAutomaton _ _ [] = return []-unfoldAutomaton auto i (mx:mxs) = do- (b, auto) <- runStep auto $ maybe [] (\x -> [toValue i x]) mx- bs <- unfoldAutomaton auto i mxs- return (b:bs)-
− src/Reactive/Banana/Internal/PulseLatch0.hs
@@ -1,566 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, RecursiveDo, ExistentialQuantification,- TypeSynonymInstances, FlexibleInstances #-}-module Reactive.Banana.Internal.PulseLatch0 where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Trans.RWS-import Control.Monad.IO.Class--import Data.IORef-import Data.Monoid (Endo(..))--import Control.Concurrent.MVar--import Reactive.Banana.Internal.Cached-import Reactive.Banana.Internal.InputOutput-import qualified Reactive.Banana.Internal.DependencyGraph as Deps-import Reactive.Banana.Frameworks.AddHandler--import Data.Hashable-import Data.Unique.Really-import qualified Data.Vault.Lazy as Vault--import Data.Functor.Identity-import System.IO.Unsafe--import Debug.Trace--type Deps = Deps.Deps--debug s m = m-debugIO s m = liftIO (putStrLn s) >> m--{------------------------------------------------------------------------------ Graph data type-------------------------------------------------------------------------------}-data Graph = Graph- { grPulse :: Values -- pulse values- , grLatch :: Values -- latch values- - , grCache :: Values -- cache for initialization-- , grDeps :: Deps SomeNode -- dependency information- , grInputs :: [Input] -- input nodes- }--type Values = Vault.Vault-type Key = Vault.Key-type Input =- ( SomeNode- , InputValue -> Values -> Values -- write input value into graph- )--emptyGraph :: Graph-emptyGraph = Graph- { grPulse = Vault.empty- , grLatch = Vault.empty- , grCache = Vault.empty- , grDeps = Deps.empty- , grInputs = [(P alwaysP, const id)]- }--{------------------------------------------------------------------------------ Graph evaluation-------------------------------------------------------------------------------}--- evaluate all the nodes in the graph once-evaluateGraph :: [InputValue] -> Graph -> Setup Graph-evaluateGraph inputs = fmap snd- . uncurry (runNetworkAtomicT . performEvaluation)- . buildEvaluationOrder- . writeInputValues inputs--runReactimates (graph,reactimates) =- sequence_ [action | pulse <- reactimates- , Just action <- [readPulseValue pulse graph]]-readPulseValue p = getValueP p . grPulse--writeInputValues inputs graph = graph { grPulse =- concatenate [f x | (_,f) <- grInputs graph, x <- inputs] Vault.empty }--concatenate :: [a -> a] -> (a -> a)-concatenate = foldr (.) id--performEvaluation :: [SomeNode] -> NetworkSetup ()-performEvaluation = mapM_ evaluate- where- evaluate (P p) = evaluateP p- evaluate (L l) = liftNetwork $ evaluateL l---- Figure out which nodes need to be evaluated.------ All nodes that are connected to current input nodes must be evaluated.--- The other nodes don't have to be evaluated, because they yield--- Nothing / don't change anyway.-buildEvaluationOrder :: Graph -> ([SomeNode], Graph)-buildEvaluationOrder graph = (Deps.topologicalSort $ grDeps graph, graph)---{------------------------------------------------------------------------------ Network monad-------------------------------------------------------------------------------}--- The 'Network' monad is used for evaluation and changes--- the state of the graph.-type NetworkT = RWST Graph (Endo Graph) Graph-type Network = NetworkT Identity-type NetworkSetup = NetworkT Setup---- lift pure Network computation into any monad--- very useful for its laziness-liftNetwork :: Monad m => Network a -> NetworkT m a-liftNetwork m = RWST $ \r s -> return . runIdentity $ runRWST m r s---- access initialization cache-instance (MonadFix m, Functor m) => HasVault (NetworkT m) where- retrieve key = Vault.lookup key . grCache <$> get- write key a = modify $ \g -> g { grCache = Vault.insert key a (grCache g) }---- change a graph "atomically"-runNetworkAtomicT :: MonadFix m => NetworkT m a -> Graph -> m (a, Graph)-runNetworkAtomicT m g1 = mdo- (x, g2, w2) <- runRWST m g3 g1 -- apply early graph gransformations- let g3 = appEndo w2 g2 -- apply late graph transformations- return (x, g3)---- write pulse value immediately-writePulse :: Key (Maybe a) -> Maybe a -> Network ()-writePulse key x =- modify $ \g -> g { grPulse = Vault.insert key x $ grPulse g }---- read pulse value immediately-readPulse :: Key (Maybe a) -> Network (Maybe a)-readPulse key = (getPulse key . grPulse) <$> get--getPulse key = join . Vault.lookup key---- write latch value immediately-writeLatch :: Key a -> a -> Network ()-writeLatch key x =- modify $ \g -> g { grLatch = Vault.insert key x $ grLatch g }---- read latch value immediately-readLatch :: Key a -> Network a-readLatch key = (maybe err id . Vault.lookup key . grLatch) <$> get- where err = error "readLatch: latch not initialized!"---- write latch value for future-writeLatchFuture :: Key a -> a -> Network ()-writeLatchFuture key x =- tell $ Endo $ \g -> g { grLatch = Vault.insert key x $ grLatch g }---- read future latch value--- Note [LatchFuture]:--- warning: forcing the value early will likely result in an infinite loop-readLatchFuture :: Key a -> Network a-readLatchFuture key = (maybe err id . Vault.lookup key . grLatch) <$> ask- where err = error "readLatchFuture: latch not found!"---- add a dependency-dependOn :: SomeNode -> SomeNode -> Network ()-dependOn x y = modify $ \g -> g { grDeps = Deps.dependOn x y $ grDeps g }--dependOns :: SomeNode -> [SomeNode] -> Network ()-dependOns x = mapM_ $ dependOn x---- link a Pulse key to an input channel-addInput :: Key (Maybe a) -> Pulse a -> InputChannel a -> Network ()-addInput key pulse channel =- modify $ \g -> g { grInputs = (P pulse, input) : grInputs g }- where- input value- | getChannel value == getChannel channel =- Vault.insert key (fromValue channel value)- | otherwise = id--{------------------------------------------------------------------------------ Setup monad-------------------------------------------------------------------------------}-{-- The 'Setup' monad allows us to do administrative tasks- during graph evaluation.- For instance, we can- * add new reactimates- * perform IO--}--type Reactimate = Pulse (IO ())-type SetupConf =- ( [Reactimate] -- reactimate- , [AddHandler [InputValue]] -- fromAddHandler- , [IO ()] -- liftIOLater- )-type Setup = RWST () SetupConf () IO--addReactimate :: Reactimate -> Setup ()-addReactimate x = tell ([x],[],[])--liftIOLater :: IO () -> Setup ()-liftIOLater x = tell ([],[],[x])--discardSetup :: Setup a -> IO a-discardSetup m = do- (a,_,_) <- runRWST m () ()- return a--registerHandler :: AddHandler [InputValue] -> Setup ()-registerHandler x = tell ([],[x],[])--runSetup :: Callback -> Setup a -> IO (a, [Reactimate])-runSetup callback m = do- (a,_,(reactimates,addHandlers,liftIOLaters)) <- runRWST m () ()- mapM_ ($ callback) addHandlers -- register new event handlers- sequence_ liftIOLaters -- execute late IOs- return (a,reactimates)--{------------------------------------------------------------------------------ Compilation.- State machine IO stuff.-------------------------------------------------------------------------------}-type Callback = [InputValue] -> IO ()--data EventNetwork = EventNetwork- { actuate :: IO ()- , pause :: IO ()- }---- compile to an event network-compile :: NetworkSetup () -> IO EventNetwork-compile setup = do- actuated <- newIORef False -- flag to set running status- rstate <- newEmptyMVar -- setup callback machinery- let- whenFlag flag action = readIORef flag >>= \b -> when b action- callback inputs = whenFlag actuated $ do- state0 <- takeMVar rstate -- read and take lock- -- pollValues <- sequence polls -- poll mutable data- (reactimates, state1)- <- step inputs state0 -- calculate new state- putMVar rstate state1 -- write state- reactimates -- run IO actions afterwards-- -- register event handlers- -- register :: IO (IO ())- -- register = fmap sequence_ . sequence . map ($ run) $ inputs-- step inputs (g0,r0) = do -- evaluation function- (g2,r1) <- runSetup callback $ evaluateGraph inputs g0- let- r2 = r0 ++ r1 -- concatenate reactimates- runner = runReactimates (g2,r2) -- don't run them yet!- return (runner, (g2,r2))-- ((_,graph), reactimates) -- compile initial graph- <- runSetup callback $ runNetworkAtomicT setup emptyGraph- putMVar rstate (graph,reactimates) -- set initial state- - return $ EventNetwork- { actuate = writeIORef actuated True- , pause = writeIORef actuated False- }---- make an interpreter-interpret :: (Pulse a -> NetworkSetup (Pulse b)) -> [Maybe a] -> IO [Maybe b]-interpret f xs = do- i <- newInputChannel- (result,graph) <- discardSetup $- runNetworkAtomicT (f =<< liftNetwork (inputP i)) emptyGraph-- let- step Nothing g0 = return (Nothing,g0)- step (Just a) g0 = do- g1 <- discardSetup $ evaluateGraph [toValue i a] g0- return (readPulseValue result g1, g1)- - mapAccumM step graph xs--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)--{------------------------------------------------------------------------------ Pulse and Latch types-------------------------------------------------------------------------------}-{-- evaluateL/P- calculates the next value and makes sure that it's cached- valueL/P- retrieves the current value- futureL- future value of the latch- see note [LatchFuture]- uidL/P- used for dependency tracking and evaluation order--}--data Pulse a = Pulse- { evaluateP :: NetworkSetup ()- , getValueP :: Values -> Maybe a- , uidP :: Unique- }--data Latch a = Latch- { evaluateL :: Network ()- , valueL :: Network a- , futureL :: Network a- , uidL :: Unique- }---valueP :: Pulse a -> Network (Maybe a)-valueP p = getValueP p . grPulse <$> get--{--* Note [LatchCreation]--When creating a new latch from a pulse, we assume that the-pulse cannot fire at the moment that the latch is created.-This is important when switching latches, because of note [PulseCreation].--Likewise, when creating a latch, we assume that we do not-have to calculate the previous latch value.--* 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.---}---- make pulse from evaluation function-pulse' :: NetworkSetup (Maybe a) -> Network (Pulse a)-pulse' eval = unsafePerformIO $ do- key <- Vault.newKey- uid <- newUnique- return $ return $ Pulse- { evaluateP = liftNetwork . writePulse key =<< eval- , getValueP = getPulse key- , uidP = uid- }--pulse :: Network (Maybe a) -> Network (Pulse a)-pulse = pulse' . liftNetwork--neverP :: Network (Pulse a)-neverP = debug "neverP" $ unsafePerformIO $ do- uid <- newUnique- return $ return $ Pulse- { evaluateP = return ()- , getValueP = const Nothing- , uidP = uid- }---- create a pulse that listens to input values-inputP :: InputChannel a -> Network (Pulse a)-inputP channel = debug "inputP" $ unsafePerformIO $ do- key <- Vault.newKey- uid <- newUnique- return $ do- let- p = Pulse- { evaluateP = return ()- , getValueP = getPulse key- , uidP = uid- }- addInput key p channel- return p---- event that always fires whenever the network processes events-alwaysP :: Pulse ()-alwaysP = debug "alwaysP" $ unsafePerformIO $ do- uid <- newUnique- return $ Pulse- { evaluateP = return ()- , getValueP = return $ Just ()- , uidP = uid- }---- make latch from initial value, a future value and evaluation function-latch :: a -> a -> Network (Maybe a) -> Network (Latch a)-latch now future eval = unsafePerformIO $ do- key <- Vault.newKey- uid <- newUnique- return $ do- -- Initialize with current and future latch value.- -- See note [LatchCreation].- writeLatch key now- writeLatchFuture key future- - return $ Latch- { evaluateL = maybe (return ()) (writeLatchFuture key) =<< eval- , valueL = readLatch key- , futureL = readLatchFuture key- , uidL = uid- }--pureL :: a -> Network (Latch a)-pureL a = debug "pureL" $ unsafePerformIO $ do- uid <- liftIO newUnique- return $ return $ Latch- { evaluateL = return ()- , valueL = return a- , futureL = return a- , uidL = uid- }--{------------------------------------------------------------------------------ Existential quantification over Pulse and Latch- for dependency tracking-------------------------------------------------------------------------------}-data SomeNode = forall a. P (Pulse a) | forall a. L (Latch a)--instance Eq SomeNode where- (L x) == (L y) = uidL x == uidL y- (P x) == (P y) = uidP x == uidP y- _ == _ = False--instance Hashable SomeNode where- hashWithSalt s (P p) = hashWithSalt s . hashUnique $ uidP p- hashWithSalt s (L l) = hashWithSalt s . hashUnique $ uidL l--{------------------------------------------------------------------------------ Combinators - basic-------------------------------------------------------------------------------}-stepperL :: a -> Pulse a -> Network (Latch a)-stepperL a p = debug "stepperL" $ do- -- @a@ is indeed the future latch value. See note [LatchCreation].- x <- latch a a (valueP p)- L x `dependOn` P p- return x--accumP :: a -> Pulse (a -> a) -> Network (Pulse a)-accumP a p = debug "accumP" $ mdo- x <- stepperL a result- result <- pulse $ eval <$> valueL x <*> valueP p- -- Evaluation order of the result pulse does *not*- -- depend on the latch. It does depend on latch value,- -- though, so don't garbage collect that one.- P result `dependOn` P p- return result- where- eval _ Nothing = Nothing- eval x (Just f) = let y = f x in y `seq` Just y -- strict evaluation--applyP :: Latch (a -> b) -> Pulse a -> Network (Pulse b)-applyP f x = debug "applyP" $ do- result <- pulse $ fmap <$> valueL f <*> valueP x- P result `dependOn` P x- return result---- tag a pulse with future values of a latch--- Caveat emptor.-tagFuture :: Latch a -> Pulse b -> Network (Pulse a)-tagFuture f x = debug "tagFuture" $ do- result <- pulse $ fmap . const <$> futureL f <*> valueP x- P result `dependOn` P x- return result--mapP :: (a -> b) -> Pulse a -> Network (Pulse b)-mapP f p = debug "mapP" $ do- result <- pulse $ fmap f <$> valueP p- P result `dependOn` P p- return result--filterJustP :: Pulse (Maybe a) -> Network (Pulse a)-filterJustP p = debug "filterJustP" $ do- result <- pulse $ join <$> valueP p- P result `dependOn` P p- return result--unionWith :: (a -> a -> a) -> Pulse a -> Pulse a -> Network (Pulse a)-unionWith f px py = debug "unionWith" $ do- result <- pulse $ eval <$> valueP px <*> valueP py- P result `dependOns` [P px, P py]- return result- 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---applyL :: Latch (a -> b) -> Latch a -> Network (Latch b)-applyL lf lx = debug "applyL" $ do- -- The value in the next cycle is always the future value.- -- See note [LatchCreation]- let eval = ($) <$> futureL lf <*> futureL lx- future <- eval- now <- ($) <$> valueL lf <*> valueL lx- result <- latch now future $ fmap Just eval- L result `dependOns` [L lf, L lx]- return result--{------------------------------------------------------------------------------ Combinators - dynamic event switching-------------------------------------------------------------------------------}-executeP :: Pulse (NetworkSetup a) -> Network (Pulse a)-executeP pn = do- result <- pulse' $ do- mp <- liftNetwork $ valueP pn- case mp of- Just p -> Just <$> p- Nothing -> return Nothing- P result `dependOn` P pn- return result--switchP :: Pulse (Pulse a) -> Network (Pulse a)-switchP pp = mdo- never <- neverP- lp <- stepperL never pp- let- eval = do- newPulse <- valueP pp- case newPulse of- Nothing -> return ()- Just p -> P result `dependOn` P p -- check in new pulse- valueP =<< valueL lp -- fetch value from old pulse- -- we have to use the *old* event value due to note [LatchCreation]- result <- pulse eval- P result `dependOns` [L lp, P pp]- return result---switchL :: Latch a -> Pulse (Latch a) -> Network (Latch a)-switchL l p = mdo- ll <- stepperL l p- let- -- switch to a new latch- switchTo l = do- L result `dependOn` L l- futureL l- -- calculate future value of the result latch- eval = do- mp <- valueP p- case mp of- Nothing -> futureL =<< valueL ll- Just l -> switchTo l-- now <- valueL l -- see note [LatchCreation]- future <- futureL l- result <- latch now future $ Just <$> eval- L result `dependOns` [L l, P p]- return result--
− src/Reactive/Banana/Internal/Types2.hs
@@ -1,63 +0,0 @@-{------------------------------------------------------------------------------ reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.Types2 (- -- | Primitive types.- Event (..), Behavior (..), Moment (..)- ) where--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Fix--import qualified Reactive.Banana.Internal.EventBehavior1 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,--> type Event t a = [(Time,a)]--}-newtype Event t a = E { unE :: Prim.Event [a] }--{-| @Behavior t a@ represents a value that varies in time. Think of it as--> type Behavior t a = Time -> a--}-newtype Behavior t a = B { unB :: Prim.Behavior 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.--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.--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@.---}-newtype Moment t a = M { unM :: Prim.Moment a }----- boilerplate class instances-instance Monad (Moment t) where- return = M . return- m >>= g = M $ unM m >>= unM . g--instance Applicative (Moment t) where- pure = M . pure- f <*> a = M $ unM f <*> unM a--instance MonadFix (Moment t) where mfix f = M $ mfix (unM . f)-instance Functor (Moment t) where fmap f = M . fmap f . unM--instance Frameworks t => MonadIO (Moment t) where- liftIO = M . Prim.liftIONow
src/Reactive/Banana/Model.hs view
@@ -1,6 +1,7 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------}+{-# LANGUAGE BangPatterns #-} module Reactive.Banana.Model ( -- * Synopsis -- | Model implementation of the abstract syntax tree.@@ -48,8 +49,8 @@ {----------------------------------------------------------------------------- Basic Combinators ------------------------------------------------------------------------------}-type Event a = [Maybe a] -- should be abstract-data Behavior a = StepperB a (Event a) -- should be abstract+type Event a = [Maybe a] -- should be abstract+data Behavior a = StepperB !a (Event a) -- should be abstract interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] interpret f e = f e 0
+ src/Reactive/Banana/Prim.hs view
@@ -0,0 +1,42 @@+{-----------------------------------------------------------------------------+ 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
+ src/Reactive/Banana/Prim/Cached.hs view
@@ -0,0 +1,72 @@+{-----------------------------------------------------------------------------+ 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+
+ src/Reactive/Banana/Prim/Combinators.hs view
@@ -0,0 +1,191 @@+{-----------------------------------------------------------------------------+ 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.++-}++
+ src/Reactive/Banana/Prim/Compile.hs view
@@ -0,0 +1,83 @@+{-----------------------------------------------------------------------------+ 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+
+ src/Reactive/Banana/Prim/Dated.hs view
@@ -0,0 +1,106 @@+{-----------------------------------------------------------------------------+ 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
+ src/Reactive/Banana/Prim/Dependencies.hs view
@@ -0,0 +1,170 @@+{-----------------------------------------------------------------------------+ 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.PQueue.Prio.Min as Q++import Reactive.Banana.Prim.Order hiding (empty)+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.+data DepsQueue a = DQ !(Q.MinPQueue Level a) !(Set a)++emptyQ :: DepsQueue a+emptyQ = DQ Q.empty Set.empty++insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a+insert k a q@(DQ queue seen) = {-# SCC insert #-}+ if a `Set.member` seen+ then q+ else DQ (Q.insert k a queue) (Set.insert a seen)++minView :: DepsQueue a -> Maybe (a, DepsQueue a)+minView (DQ queue seen) = {-# SCC minView #-} case Q.minView queue of+ Nothing -> Nothing+ Just (a, queue2) -> Just (a, DQ queue2 seen)++{-----------------------------------------------------------------------------+ 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+
+ src/Reactive/Banana/Prim/Evaluation.hs view
@@ -0,0 +1,75 @@+{-----------------------------------------------------------------------------+ 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++
+ src/Reactive/Banana/Prim/IO.hs view
@@ -0,0 +1,51 @@+{-----------------------------------------------------------------------------+ 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
+ src/Reactive/Banana/Prim/Order.hs view
@@ -0,0 +1,90 @@+{-----------------------------------------------------------------------------+ 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
+ src/Reactive/Banana/Prim/Plumbing.hs view
@@ -0,0 +1,163 @@+{-----------------------------------------------------------------------------+ 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++
+ src/Reactive/Banana/Prim/Test.hs view
@@ -0,0 +1,37 @@+{-----------------------------------------------------------------------------+ 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]++
+ src/Reactive/Banana/Prim/Types.hs view
@@ -0,0 +1,194 @@+{-----------------------------------------------------------------------------+ 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)+
src/Reactive/Banana/Switch.hs view
@@ -22,9 +22,9 @@ import Control.Applicative import Control.Monad -import Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.EventBehavior1 as Prim-import Reactive.Banana.Internal.Types2+import Reactive.Banana.Combinators+import qualified Reactive.Banana.Internal.Combinators as Prim+import Reactive.Banana.Types {----------------------------------------------------------------------------- Constant
src/Reactive/Banana/Test.hs view
@@ -5,6 +5,7 @@ ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-} +import Control.Arrow import Control.Monad (when, join) import Test.Framework (defaultMain, testGroup, Test)@@ -29,13 +30,15 @@ , testModelMatch "accumE1" accumE1 ] , testGroup "Complex"- [ testModelMatch "counter" counter- , testModelMatch "double" double- , testModelMatch "sharing" sharing- , testModelMatch "recursive1" recursive1- , testModelMatch "recursive2" recursive2- , testModelMatch "recursive3" recursive3- , testModelMatch "accumBvsE" accumBvsE+ [ 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@@ -124,6 +127,35 @@ 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]
src/Reactive/Banana/Test/Plumbing.hs view
@@ -11,8 +11,7 @@ import Control.Monad.Fix import qualified Reactive.Banana.Model as X-import qualified Reactive.Banana.Internal.EventBehavior1 as Y-import qualified Reactive.Banana.Internal.InputOutput as Y+import qualified Reactive.Banana.Internal.Combinators as Y {----------------------------------------------------------------------------- Types as pairs@@ -99,4 +98,7 @@ ------------------------------------------------------------------------------} accumB acc = stepperB acc . accumE acc whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)-b <@ e = applyE (const <$> b) e++infixl 4 <@>, <@+b <@ e = applyE (const <$> b) e+b <@> e = applyE b e
+ src/Reactive/Banana/Types.hs view
@@ -0,0 +1,80 @@+{-----------------------------------------------------------------------------+ reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Types (+ -- | Primitive types.+ Event (..), Behavior (..), Moment (..), Future(..)+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+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,++> type Event t a = [(Time,a)]+-}+newtype Event t a = E { unE :: Prim.Event [a] }++{-| @Behavior t a@ represents a value that varies in time. Think of it as++> type Behavior t a = Time -> a+-}+newtype Behavior t a = B { unB :: Prim.Behavior a }++-- | The 'Future' monad is just a helper type for the 'changes' function.+-- +-- A value of type @Future a@ is only available in the context+-- of a 'reactimate' but not during event processing.+newtype Future a = F { unF :: Prim.Future a }++-- boilerplate class instances+instance Functor Future where fmap f = F . fmap f . unF++instance Monad Future where+ 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.++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.++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@.++-}+newtype Moment t a = M { unM :: Prim.Moment a }++-- boilerplate class instances+instance Functor (Moment t) where fmap f = M . fmap f . unM++instance Monad (Moment t) where+ return = M . return+ m >>= g = M $ unM m >>= unM . g++instance Applicative (Moment t) where+ pure = M . pure+ f <*> a = M $ unM f <*> unM a++instance MonadFix (Moment t) where mfix f = M $ mfix (unM . f)++instance Frameworks t => MonadIO (Moment t) where+ liftIO = M . Prim.liftIONow