reactive-banana-0.7.1.3/0000755000000000000000000000000012176662610013075 5ustar0000000000000000reactive-banana-0.7.1.3/LICENSE0000644000000000000000000000277312176662610014113 0ustar0000000000000000Copyright (c)2011, Heinrich Apfelmus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Heinrich Apfelmus nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. reactive-banana-0.7.1.3/reactive-banana.cabal0000644000000000000000000001001412176662610017075 0ustar0000000000000000Name: 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). . 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. . See the project homepage for a more detailed introduction and features. . 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. Homepage: http://haskell.org/haskellwiki/Reactive-banana License: BSD3 License-file: LICENSE Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus Stability: Experimental Category: FRP Cabal-version: >= 1.9.2 Build-type: Simple extra-source-files: doc/examples/*.hs, src/Reactive/Banana/Test.hs src/Reactive/Banana/Test/Plumbing.hs Source-repository head type: git location: git://github.com/HeinrichApfelmus/reactive-banana.git subdir: reactive-banana/ flag UseExtensions description: Use GHC-specific language extensions. This enables the efficient push-driven implementation, but doesn't necessarily work with compilers other than GHC. -- Cabal checks if the package can be build with UseExtensions = True, -- otherewise it is set to False . Library hs-source-dirs: src extensions: RecursiveDo, Rank2Types, ScopedTypeVariables, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction build-depends: base >= 4.2 && < 5, containers >= 0.3 && < 0.6, transformers >= 0.2 && < 0.4, vault == 0.3.* extensions: EmptyDataDecls, BangPatterns build-depends: unordered-containers >= 0.2.1.0 && < 0.3, hashable >= 1.1 && < 1.3 -- CPP-options: -DUseExtensions exposed-modules: Reactive.Banana, Reactive.Banana.Combinators, Reactive.Banana.Experimental.Calm, Reactive.Banana.Frameworks, Reactive.Banana.Frameworks.AddHandler, Reactive.Banana.Model Reactive.Banana.Switch other-modules: Reactive.Banana.Internal.Cached, Reactive.Banana.Internal.DependencyGraph, Reactive.Banana.Internal.EventBehavior1, Reactive.Banana.Internal.InputOutput Reactive.Banana.Internal.Phantom, Reactive.Banana.Internal.PulseLatch0, Reactive.Banana.Internal.Types2 -- compiling the test suite from cabal currently doesn't work Test-Suite tests type: exitcode-stdio-1.0 hs-source-dirs: src main-is: Reactive/Banana/Test.hs build-depends: base >= 4.2 && < 5, HUnit >= 1.2 && < 2, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, reactive-banana, vault, containers, transformers, unordered-containers, hashable reactive-banana-0.7.1.3/Setup.hs0000644000000000000000000000005612176662610014532 0ustar0000000000000000import Distribution.Simple main = defaultMain reactive-banana-0.7.1.3/doc/0000755000000000000000000000000012176662610013642 5ustar0000000000000000reactive-banana-0.7.1.3/doc/examples/0000755000000000000000000000000012176662610015460 5ustar0000000000000000reactive-banana-0.7.1.3/doc/examples/ActuatePause.hs0000644000000000000000000000470512176662610020406 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: Actuate and pause an event network ------------------------------------------------------------------------------} import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub) import System.Random import System.IO import Debug.Trace import Data.IORef import Reactive.Banana import Reactive.Banana.Frameworks main :: IO () main = do displayHelpMessage sources <- (,) <$> newAddHandler <*> newAddHandler network <- setupNetwork sources actuate network eventLoop sources network displayHelpMessage :: IO () displayHelpMessage = mapM_ putStrLn $ "Commands are:": " count - send counter event": " pause - pause event network": " actuate - actuate event network": " quit - quit the program": "": [] -- Read commands and fire corresponding events eventLoop :: (EventSource (),EventSource EventNetwork) -> EventNetwork -> IO () eventLoop (escounter, espause) network = loop where loop = do putStr "> " hFlush stdout s <- getLine case s of "count" -> fire escounter () "pause" -> fire espause network "actuate" -> actuate network "quit" -> return () _ -> putStrLn $ s ++ " - unknown command" when (s /= "quit") loop {----------------------------------------------------------------------------- Event sources ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you type EventSource a = (AddHandler a, a -> IO ()) addHandler :: EventSource a -> AddHandler a addHandler = fst fire :: EventSource a -> a -> IO () fire = snd {----------------------------------------------------------------------------- Program logic ------------------------------------------------------------------------------} -- Set up the program logic in terms of events and behaviors. setupNetwork :: (EventSource (),EventSource EventNetwork) -> IO EventNetwork setupNetwork (escounter, espause) = compile $ do ecounter <- fromAddHandler (addHandler escounter) epause <- fromAddHandler (addHandler espause ) let ecount = accumE 0 ((+1) <$ ecounter) reactimate $ fmap print ecount reactimate $ fmap pause epause reactive-banana-0.7.1.3/doc/examples/SlotMachine.hs0000644000000000000000000001264712176662610020234 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Example: Slot machine ------------------------------------------------------------------------------} {-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub) import System.Random import System.IO import Debug.Trace import Data.IORef import Reactive.Banana as R import Reactive.Banana.Frameworks as R main :: IO () main = do displayHelpMessage sources <- makeSources network <- compile $ setupNetwork sources actuate network eventLoop sources displayHelpMessage :: IO () displayHelpMessage = mapM_ putStrLn $ "-----------------------------": "- THE REACTIVE SLOT MACHINE -": "------ WIN A BANANA ---------": "": "Commands are:": " coin - insert a coin": " play - play one game": " quit - quit the program": "": [] -- Create event sources corresponding to coin and play makeSources = (,) <$> newAddHandler <*> newAddHandler -- Read commands and fire corresponding events eventLoop :: (EventSource (), EventSource ()) -> IO () eventLoop (escoin,esplay) = loop where loop = do putStr "> " hFlush stdout s <- getLine case s of "coin" -> fire escoin () -- fire corresponding events "play" -> fire esplay () "quit" -> return () _ -> putStrLn $ s ++ " - unknown command" when (s /= "quit") loop {----------------------------------------------------------------------------- Event sources ------------------------------------------------------------------------------} -- Event Sources - allows you to register event handlers -- Your GUI framework should provide something like this for you type EventSource a = (AddHandler a, a -> IO ()) addHandler :: EventSource a -> AddHandler a addHandler = fst fire :: EventSource a -> a -> IO () fire = snd {----------------------------------------------------------------------------- Program logic ------------------------------------------------------------------------------} type Money = Int -- State of the reels, consisting of three numbers from 1-4. Example: "222" type Reels = (Int,Int,Int) -- A win consist of either double or triple numbers data Win = Double | Triple -- payout for each win payout :: Win -> Money payout Double = 20 payout Triple = 200 -- Set up the program logic in terms of events and behaviors. setupNetwork :: forall t. Frameworks t => (EventSource (), EventSource ()) -> Moment t () setupNetwork (escoin,esplay) = do -- initial random number generator initialStdGen <- liftIONow $ newStdGen -- Obtain events corresponding to the coin and play commands ecoin <- fromAddHandler (addHandler escoin) eplay <- fromAddHandler (addHandler esplay) let -- The state of the slot machine is captured in Behaviors. -- State: credits that the player has to play the game -- The ecoin event adds a coin to the credits -- The edoesplay event removes money -- The ewin event adds credits because the player has won bcredits :: Behavior t Money ecredits :: Event t Money (ecredits, bcredits) = mapAccum 0 . fmap (\f x -> (f x,f x)) $ ((addCredit <$ ecoin) `union` (removeCredit <$ edoesplay) `union` (addWin <$> ewin)) -- functions that change the accumulated state addCredit = (+1) removeCredit = subtract 1 addWin Double = (+5) addWin Triple = (+20) -- Event: does the player have enough money to play the game? emayplay :: Event t Bool emayplay = apply ((\credits _ -> credits > 0) <$> bcredits) eplay -- Event: player has enough coins and plays edoesplay :: Event t () edoesplay = () <$ filterE id emayplay -- Event: event that fires when the player doesn't have enough money edenied :: Event t () edenied = () <$ filterE not emayplay -- State: random number generator bstdgen :: Behavior t StdGen eroll :: Event t Reels -- accumulate the random number generator while rolling the reels (eroll, bstdgen) = mapAccum initialStdGen (roll <$> edoesplay) -- roll the reels roll :: () -> StdGen -> (Reels, StdGen) roll () gen0 = ((z1,z2,z3),gen3) where random = randomR(1,4) (z1,gen1) = random gen0 (z2,gen2) = random gen1 (z3,gen3) = random gen2 -- Event: it's a win! ewin :: Event t Win ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll checkWin (z1,z2,z3) | length (nub [z1,z2,z3]) == 1 = Just Triple | length (nub [z1,z2,z3]) == 2 = Just Double | otherwise = Nothing reactimate $ putStrLn . showCredit <$> ecredits reactimate $ putStrLn . showRoll <$> eroll reactimate $ putStrLn . showWin <$> ewin reactimate $ putStrLn "Not enough credits!" <$ edenied showCredit money = "Credits: " ++ show money showRoll (z1,z2,z3) = "You rolled " ++ show z1 ++ show z2 ++ show z3 showWin Double = "Wow, a double!" showWin Triple = "Wowwowow! A triple! So awesome!" reactive-banana-0.7.1.3/src/0000755000000000000000000000000012176662610013664 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/0000755000000000000000000000000012176662610015426 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana.hs0000644000000000000000000000076512176662610017152 0ustar0000000000000000{----------------------------------------------------------------------------- Reactive Banana A small library for functional reactive programming. ------------------------------------------------------------------------------} module Reactive.Banana ( module Reactive.Banana.Combinators, module Reactive.Banana.Switch, compile, ) where import Reactive.Banana.Combinators import Reactive.Banana.Frameworks import Reactive.Banana.Internal.Types2 import Reactive.Banana.Switchreactive-banana-0.7.1.3/src/Reactive/Banana/0000755000000000000000000000000012176662610016606 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana/Combinators.hs0000644000000000000000000002467112176662610021434 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} module Reactive.Banana.Combinators ( -- * Synopsis -- | Combinators for building event graphs. -- * Introduction -- $intro1 Event, Behavior, -- $intro2 interpret, -- * Core Combinators module Control.Applicative, module Data.Monoid, never, union, unions, filterE, collect, spill, accumE, apply, stepper, -- $classes -- * Derived Combinators -- ** Filtering filterJust, filterApply, whenE, split, -- ** Accumulation -- $Accumulation. 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 {----------------------------------------------------------------------------- Introduction ------------------------------------------------------------------------------} {-$intro1 At its core, Functional Reactive Programming (FRP) is about two data types 'Event' and 'Behavior' and the various ways to combine them. -} -- Event -- Behavior {-$intro2 As you can see, both types seem to have a superfluous parameter @t@. The library uses it to rule out certain gross inefficiencies, in particular in connection with dynamic event switching. For basic stuff, you can completely ignore it, except of course for the fact that it will annoy you in your type signatures. While the type synonyms mentioned above are the way you should think about 'Behavior' and 'Event', they are a bit vague for formal manipulation. To remedy this, the library provides a very simple but authoritative model implementation. See "Reactive.Banana.Model" for more. -} {----------------------------------------------------------------------------- Interpetation ------------------------------------------------------------------------------} -- | Interpret an event processing function. -- Useful for testing. interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] interpret f xs = map toList <$> Prim.interpret (return . unE . f . E) (map Just xs) toList :: Maybe [a] -> [a] toList Nothing = [] toList (Just xs) = xs {----------------------------------------------------------------------------- Core combinators ------------------------------------------------------------------------------} singleton :: a -> [a] singleton x = [x] -- | Event that never occurs. -- Think of it as @never = []@. never :: Event t a never = E $ Prim.mapE singleton Prim.never -- | Merge two event streams of the same type. -- In case of simultaneous occurrences, the left argument comes first. -- Think of it as -- -- > union ((timex,x):xs) ((timey,y):ys) -- > | timex <= timey = (timex,x) : union xs ((timey,y):ys) -- > | timex > timey = (timey,y) : union ((timex,x):xs) ys union :: Event t a -> Event t a -> Event t a union e1 e2 = E $ Prim.unionWith (++) (unE e1) (unE e2) -- | Merge several event streams of the same type. -- -- > unions = foldr union never unions :: [Event t a] -> Event t a unions = foldr union never -- | Allow all event occurrences that are 'Just' values, discard the rest. -- Variant of 'filterE'. filterJust :: Event t (Maybe a) -> Event t a filterJust = E . Prim.filterJust . Prim.mapE (decide . catMaybes) . unE where decide xs = if null xs then Nothing else Just xs -- | Allow all events that fulfill the predicate, discard the rest. -- Think of it as -- -- > filterE p es = [(time,a) | (time,a) <- es, p a] filterE :: (a -> Bool) -> Event t a -> Event t a filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing) -- | Collect simultaneous event occurences. -- The result will never contain an empty list. -- Example: -- -- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])] collect :: Event t a -> Event t [a] collect e = E $ Prim.mapE singleton (unE e) -- | Emit simultaneous event occurrences. -- The first element in the list will be emitted first, and so on. -- -- Up to strictness, we have -- -- > spill . collect = id spill :: Event t [a] -> Event t a spill e = E $ Prim.filterJust $ Prim.mapE (nonempty . concat) (unE e) where nonempty [] = Nothing nonempty xs = Just xs -- | Construct a time-varying function from an initial value and -- a stream of new values. Think of it as -- -- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time]) -- -- Note that the smaller-than-sign in the comparision @timex < time@ means -- that the value of the behavior changes \"slightly after\" -- the event occurrences. This allows for recursive definitions. -- -- Also note that in the case of simultaneous occurrences, -- only the last one is kept. stepper :: a -> Event t a -> Behavior t a stepper x e = B $ Prim.stepperB x $ Prim.mapE last $ unE e -- | The 'accumE' function accumulates a stream of events. -- Example: -- -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] -- > = [(time1,"xy"),(time2,"xyz")] -- -- Note that the output events are simultaneous with the input events, -- there is no \"delay\" like in the case of 'accumB'. accumE :: a -> Event t (a -> a) -> Event t a accumE acc = E . mapAccumE acc . Prim.mapE concatenate . unE where concatenate :: [a -> a] -> a -> ([a],a) concatenate fs acc = (tail values, last values) where values = scanl' (flip ($)) acc fs mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a mapAccumE acc = Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd) -- strict version of scanl scanl' :: (a -> b -> a) -> a -> [b] -> [a] scanl' f x ys = x : case ys of [] -> [] y:ys -> let z = f x y in z `seq` scanl' f z ys -- | Apply a time-varying function to a stream of events. -- Think of it as -- -- > apply bf ex = [(time, bf time x) | (time, x) <- ex] apply :: Behavior t (a -> b) -> Event t a -> Event t b apply bf ex = E $ Prim.applyE (Prim.mapB map $ unB bf) (unE ex) {-$classes /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. > pure :: a -> Behavior t a The constant time-varying value. Think of it as @pure x = \\time -> x@. > (<*>) :: Behavior t (a -> b) -> Behavior t a -> Behavior t b Combine behaviors in applicative style. Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. -} {- No monoid instance, sorry. instance Monoid (Event t (a -> a)) where mempty = never mappend = unionWith (flip (.)) -} instance Functor (Event t) where fmap f e = E $ Prim.mapE (map f) (unE e) instance Applicative (Behavior t) where pure x = B $ Prim.pureB x bf <*> bx = B $ Prim.applyB (unB bf) (unB bx) instance Functor (Behavior t) where fmap = liftA {----------------------------------------------------------------------------- Derived Combinators ------------------------------------------------------------------------------} {- Unfortunately, we can't make a Num instance because that would require Eq and Show . instance Num a => Num (Behavior t a) where (+) = liftA2 (+) (-) = liftA2 (-) (*) = liftA2 (*) negate = fmap negate abs = fmap abs signum = fmap signum fromInteger = pure . fromInteger -} -- | Allow all events that fulfill the time-varying predicate, discard the rest. -- Generalization of 'filterE'. filterApply :: Behavior t (a -> Bool) -> Event t a -> Event t a filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp) -- | Allow events only when the behavior is 'True'. -- Variant of 'filterApply'. whenE :: Behavior t Bool -> Event t a -> Event t a whenE bf = filterApply (const <$> bf) -- | Split event occurrences according to a tag. -- The 'Left' values go into the left component while the 'Right' values -- go into the right component of the result. split :: Event t (Either a b) -> (Event t a, Event t b) split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) where fromLeft (Left a) = Just a fromLeft (Right b) = Nothing fromRight (Left a) = Nothing fromRight (Right b) = Just b -- | Combine simultaneous event occurrences into a single occurrence. -- -- > unionWith f e1 e2 = fmap (foldr1 f) <$> collect (e1 `union` e2) unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a unionWith f e1 e2 = E $ Prim.unionWith g (unE e1) (unE e2) where g xs ys = singleton $ foldr1 f (xs ++ ys) -- | Keep only the last occurrence when simultaneous occurrences happen. calm :: Event t a -> Event t a calm = fmap last . collect -- $Accumulation. -- Note: all accumulation functions are strict in the accumulated value! -- acc -> (x,acc) is the order used by 'unfoldr' and 'State'. -- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. -- It starts with an initial value and combines it with incoming events. -- For example, think -- -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] -- > = stepper "x" [(time1,"xy"),(time2,"xyz")] -- -- Note that the value of the behavior changes \"slightly after\" -- the events occur. This allows for recursive definitions. accumB :: a -> Event t (a -> a) -> Behavior t a -- accumB x (Event e) = behavior $ AccumB x e accumB acc = stepper acc . accumE acc -- | Efficient combination of 'accumE' and 'accumB'. mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e)) where e = accumE (undefined,acc) ((. snd) <$> ef) 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Frameworks.hs0000644000000000000000000002725112176662610021271 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types #-} module Reactive.Banana.Frameworks ( -- * Synopsis -- | Build event networks using existing event-based frameworks -- and run them. -- * Simple use interpretAsHandler, -- * Building event networks with input/output -- $build compile, Frameworks, AddHandler, fromAddHandler, fromChanges, fromPoll, reactimate, initial, changes, FrameworksMoment(..), execute, liftIOLater, liftIONow, -- $liftIO module Control.Monad.IO.Class, -- * Running event networks EventNetwork, actuate, pause, -- * Utilities -- $utilities newAddHandler, newEvent, module Reactive.Banana.Frameworks.AddHandler, -- * Internal interpretFrameworks, ) where import Control.Monad import Control.Monad.IO.Class import Data.IORef 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 ------------------------------------------------------------------------------} {-$build After having read all about 'Event's and 'Behavior's, you want to hook them up to an existing event-based framework, like @wxHaskell@ or @Gtk2Hs@. How do you do that? The module presented here allows you to * obtain /input/ events from external sources and to * perform /output/ in reaction to events. In constrast, the functions from "Reactive.Banana.Combinators" allow you to express the output events in terms of the input events. This expression is called an /event graph/. An /event network/ is an event graph together with inputs and outputs. To build an event network, describe the inputs, outputs and event graph in the 'Moment' monad and use the 'compile' function to obtain an event network from that. To /activate/ an event network, use the 'actuate' function. The network will register its input event handlers and start producing output. A typical setup looks like this: > main = do > -- initialize your GUI framework > window <- newWindow > ... > > -- describe the event network > let networkDescription :: forall t. Frameworks t => Moment t () > networkDescription = do > -- input: obtain Event from functions that register event handlers > emouse <- fromAddHandler $ registerMouseEvent window > ekeyboard <- fromAddHandler $ registerKeyEvent window > -- input: obtain Behavior from changes > btext <- fromChanges "" $ registerTextChange editBox > -- input: obtain Behavior from mutable data by polling > bdie <- fromPoll $ randomRIO (1,6) > > -- express event graph > let > behavior1 = accumB ... > ... > event15 = union event13 event14 > > -- output: animate some event occurences > reactimate $ fmap print event15 > reactimate $ fmap drawCircle eventCircle > > -- compile network description into a network > network <- compile networkDescription > -- register handlers and start producing outputs > actuate network In short, * Use 'fromAddHandler' to obtain /input/ events. The library uses this to register event handlers with your event-based framework. * Use 'reactimate' to animate /output/ events. -} {----------------------------------------------------------------------------- Combinators ------------------------------------------------------------------------------} singletonsE :: Prim.Event a -> Event t a singletonsE = E . Prim.mapE (:[]) {- | Output. Execute the 'IO' action whenever the event occurs. Note: If two events occur very close to each other, there is no guarantee that the @reactimate@s for one event will have finished before the ones for the next event start executing. This does /not/ affect the values of events and behaviors, it only means that the @reactimate@ for different events may interleave. Fortuantely, this is a very rare occurrence, and only happens if * you call an event handler from inside 'reactimate', * or you use concurrency. In these cases, the @reactimate@s follow the control flow of your event-based framework. Note: An event network essentially behaves like a single, huge callback function. The 'IO' action are not run in a separate thread. The callback function will throw an exception if one of your 'IO' actions does so as well. Your event-based framework will have to handle this situation. -} reactimate :: Frameworks t => Event t (IO ()) -> Moment t () reactimate = M . Prim.addReactimate . Prim.mapE sequence_ . unE -- | Input, -- obtain an 'Event' from an 'AddHandler'. -- -- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called. fromAddHandler :: Frameworks t => AddHandler a -> Moment t (Event t a) fromAddHandler = M . fmap singletonsE . Prim.fromAddHandler -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time. -- -- The resulting 'Behavior' will be updated on whenever the event -- network processes an input event. -- -- This function is occasionally useful, but -- the recommended way to obtain 'Behaviors' is by using 'fromChanges'. -- -- Ideally, the argument IO action just polls a mutable variable, -- it should not perform expensive computations. -- Neither should its side effects affect the event network significantly. fromPoll :: Frameworks t => IO a -> Moment t (Behavior t a) fromPoll = M . fmap B . Prim.fromPoll -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes. -- -- This is essentially just an application of the 'stepper' combinator. fromChanges :: Frameworks t => a -> AddHandler a -> Moment t (Behavior t a) fromChanges initial changes = stepper initial <$> fromAddHandler changes -- | Output, -- observe when a 'Behavior' changes. -- -- Strictly speaking, a 'Behavior' denotes a value that -- varies /continuously/ in time, -- so there is no well-defined event which indicates when the behavior changes. -- -- Still, for reasons of efficiency, the library provides a way to observe -- changes when the behavior is a step function, for instance as -- created by 'stepper'. There are no formal guarantees, -- but the idea is that -- -- > 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 -- | Dummy type needed to simulate impredicative polymorphism. newtype FrameworksMoment a = FrameworksMoment { runFrameworksMoment :: forall t. Frameworks t => Moment t a } unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a unFM = runFrameworksMoment -- | Dynamically add input and output to an existing event network. -- -- Note: You can even do 'IO' actions here, but there is no -- guarantee about the order in which they are executed. execute :: Frameworks t => Event t (FrameworksMoment a) -> Moment t (Event t a) execute = M . fmap singletonsE . Prim.executeE . Prim.mapE (fmap last . sequence . map (unM . unFM) ) . unE -- $liftIO -- -- > liftIO :: Frameworks t => IO a -> Moment t a -- -- 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'. liftIOLater :: Frameworks t => IO () -> Moment t () liftIOLater = M . Prim.liftIOLater -- | Compile the description of an event network -- into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on. -- -- Event networks are described in the 'Moment' monad -- and use the 'Frameworks' class constraint. compile :: (forall t. Frameworks t => Moment t ()) -> IO EventNetwork compile m = fmap EN $ Prim.compile $ unM (m :: Moment (FrameworksD, t) ()) {----------------------------------------------------------------------------- Running event networks ------------------------------------------------------------------------------} -- | Data type that represents a compiled event network. -- It may be paused or already running. newtype EventNetwork = EN { unEN :: Prim.EventNetwork } -- | Actuate an event network. -- The inputs will register their event handlers, so that -- the networks starts to produce outputs in response to input events. actuate :: EventNetwork -> IO () actuate = Prim.actuate . unEN -- | Pause an event network. -- Immediately stop producing output and -- unregister all event handlers for inputs. -- Hence, the network stops responding to input events, -- but it's state will be preserved. -- -- You can resume the network with 'actuate'. -- -- Note: You can stop a network even while it is processing events, -- i.e. you can use 'pause' as an argument to 'reactimate'. -- The network will /not/ stop immediately though, only after -- the current event has been processed completely. pause :: EventNetwork -> IO () pause = Prim.pause . unEN {----------------------------------------------------------------------------- Simple use ------------------------------------------------------------------------------} -- | Interpret by using a framework internally. -- Only useful for testing library internals. interpretFrameworks :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]] interpretFrameworks f xs = do output <- newIORef [] (addHandler, runHandlers) <- newAddHandler network <- compile $ do e <- fromAddHandler addHandler reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) actuate network bs <- forM xs $ \x -> do runHandlers x bs <- readIORef output writeIORef output [] return bs return bs -- | Simple way to write a single event handler with -- functional reactive programming. interpretAsHandler :: (forall t. Event t a -> Event t b) -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = \handlerB -> do network <- compile $ do e <- fromAddHandler addHandlerA reactimate $ handlerB <$> f e actuate network return (pause network) {----------------------------------------------------------------------------- Utilities ------------------------------------------------------------------------------} {-$utilities This section collects a few convenience functions for unusual use cases. For instance: * The event-based framework you want to hook into is poorly designed * You have to write your own event loop and roll a little event framework -} -- | Build an 'Event' together with an 'IO' action that can -- fire occurrences of this event. Variant of 'newAddHandler'. -- -- This function is mainly useful for passing callback functions -- inside a 'reactimate'. newEvent :: Frameworks t => Moment t (Event t a, a -> IO ()) newEvent = do (addHandler, fire) <- liftIO $ newAddHandler e <- fromAddHandler addHandler return (e,fire) reactive-banana-0.7.1.3/src/Reactive/Banana/Model.hs0000644000000000000000000001146112176662610020205 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} module Reactive.Banana.Model ( -- * Synopsis -- | Model implementation of the abstract syntax tree. -- * Description -- $model -- * Combinators -- ** Data types Event, Behavior, -- ** Basic never, filterJust, unionWith, mapE, accumE, applyE, stepperB, pureB, applyB, mapB, -- ** Dynamic event switching Moment, initialB, trimE, trimB, observeE, switchE, switchB, -- * Interpretation interpret, ) where import Control.Applicative import Control.Monad (join) {-$model This module contains the model implementation for the primitive combinators defined "Reactive.Banana.Internal.AST" which in turn are the basis for the official combinators documented in "Reactive.Banana.Combinators". Look at the source code to make maximal use of this module. (If there is no link to the source code at every type signature, then you have to run cabal with --hyperlink-source flag.) This model is /authoritative/: when observed with the 'interpretModel' function, both the actual implementation and its model /must/ agree on the result. Note that this must also hold for recursive and partial definitions (at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). Concerning time and space complexity, the model is not authoritative, however. Implementations are free to be much more efficient. -} {----------------------------------------------------------------------------- Basic Combinators ------------------------------------------------------------------------------} 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 never :: Event a never = repeat Nothing filterJust :: Event (Maybe a) -> Event a filterJust = map join unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a unionWith f = zipWith g where g (Just x) (Just y) = Just $ f x y g (Just x) Nothing = Just x g Nothing (Just y) = Just y g Nothing Nothing = Nothing mapE f = applyE (pureB f) applyE :: Behavior (a -> b) -> Event a -> Event b applyE _ [] = [] applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs where step a (Nothing:b) = stepperB a b step _ (Just a :b) = stepperB a b accumE :: a -> Event (a -> a) -> Event a accumE x [] = [] accumE x (Nothing:fs) = Nothing : accumE x fs accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) stepperB :: a -> Event a -> Behavior a stepperB = StepperB -- applicative functor pureB x = stepperB x never applyB :: Behavior (a -> b) -> Behavior a -> Behavior b applyB (StepperB f fe) (StepperB x xe) = stepperB (f x) $ mapE (uncurry ($)) pair where pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe) changeL f (_,x) = (f,x) changeR x (f,_) = (f,x) mapB f = applyB (pureB f) {----------------------------------------------------------------------------- Dynamic Event Switching ------------------------------------------------------------------------------} type Time = Int type Moment a = Time -> a -- should be abstract {- instance Monad Moment where return = const m >>= g = \time -> g (m time) time -} initialB :: Behavior a -> Moment a initialB (StepperB x _) = return x trimE :: Event a -> Moment (Moment (Event a)) trimE e = \now -> \later -> drop (later - now) e trimB :: Behavior a -> Moment (Moment (Behavior a)) trimB b = \now -> \later -> bTrimmed !! (later - now) where bTrimmed = iterate drop1 b drop1 (StepperB x [] ) = StepperB x never drop1 (StepperB x (Just y :ys)) = StepperB y ys drop1 (StepperB x (Nothing:ys)) = StepperB x ys observeE :: Event (Moment a) -> Event a observeE = zipWith (\time -> fmap ($ time)) [0..] switchE :: Event (Moment (Event a)) -> Event a switchE = step never . observeE where step ys [] = ys step (y:ys) (Nothing:xs) = y : step ys xs step (y:ys) (Just zs:xs) = y : step (drop 1 zs) xs -- assume that the dynamic events are at least as long as the -- switching event switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a switchB (StepperB x e) = stepperB x . step e . observeE where step ys [] = ys step (y:ys) (Nothing :xs) = y : step ys xs step (y:ys) (Just (StepperB x zs):xs) = Just value : step (drop 1 zs) xs where value = case zs of Just z : _ -> z -- new behavior changes right away _ -> x -- new behavior stays constant for a while reactive-banana-0.7.1.3/src/Reactive/Banana/Switch.hs0000644000000000000000000000634212176662610020410 0ustar0000000000000000{----------------------------------------------------------------------------- Reactive Banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances #-} module Reactive.Banana.Switch ( -- * Synopsis -- | Dynamic event switching. -- * Moment monad Moment, AnyMoment, anyMoment, now, -- * Dynamic event switching trimE, trimB, switchE, switchB, observeE, valueB, -- * Identity Functor Identity(..), ) where import Control.Applicative import Control.Monad import Reactive.Banana.Combinators import qualified Reactive.Banana.Internal.EventBehavior1 as Prim import Reactive.Banana.Internal.Types2 {----------------------------------------------------------------------------- Constant ------------------------------------------------------------------------------} -- | Identity functor with a dummy argument. -- Unlike 'Data.Functor.Constant', -- this functor is constant in the /second/ argument. newtype Identity t a = Identity { getIdentity :: a } instance Functor (Identity t) where fmap f (Identity a) = Identity (f a) {----------------------------------------------------------------------------- Moment ------------------------------------------------------------------------------} -- | Value present at any/every moment in time. newtype AnyMoment f a = AnyMoment { now :: forall t. Moment t (f t a) } instance Monad (AnyMoment Identity) where return x = AnyMoment $ return (Identity x) (AnyMoment m) >>= g = AnyMoment $ m >>= \(Identity x) -> now (g x) instance Functor (AnyMoment Behavior) where fmap f (AnyMoment x) = AnyMoment (fmap (fmap f) x) instance Applicative (AnyMoment Behavior) where pure x = AnyMoment $ return $ pure x (AnyMoment f) <*> (AnyMoment x) = AnyMoment $ liftM2 (<*>) f x anyMoment :: (forall t. Moment t (f t a)) -> AnyMoment f a anyMoment = AnyMoment {----------------------------------------------------------------------------- Dynamic event switching ------------------------------------------------------------------------------} -- | Trim an 'Event' to a variable start time. trimE :: Event t a -> Moment t (AnyMoment Event a) trimE = M . fmap (\x -> AnyMoment (M $ fmap E x)) . Prim.trimE . unE -- | Trim a 'Behavior' to a variable start time. trimB :: Behavior t a -> Moment t (AnyMoment Behavior a) trimB = M . fmap (\x -> AnyMoment (M $ fmap B x)) . Prim.trimB . unB -- | Observe a value at those moments in time where -- event occurrences happen. observeE :: Event t (AnyMoment Identity a) -> Event t a observeE = E . Prim.observeE . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE -- | Obtain the value of the 'Behavior' at moment @t@. valueB :: Behavior t a -> Moment t a valueB = M . Prim.initialB . unB -- | Dynamically switch between 'Event'. switchE :: forall t a. Event t (AnyMoment Event a) -> Event t a switchE = E . Prim.switchE . Prim.mapE (fmap unE . unM . now . last) . unE -- | Dynamically switch between 'Behavior'. switchB :: forall t a. Behavior t a -> Event t (AnyMoment Behavior a) -> Behavior t a switchB b e = B $ Prim.switchB (unB b) $ Prim.mapE (fmap unB . unM . now . last) (unE e) reactive-banana-0.7.1.3/src/Reactive/Banana/Test.hs0000644000000000000000000001240212176662610020060 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana Test cases and examples ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-} import Control.Monad (when, join) import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assert, Assertion) -- import Test.QuickCheck -- import Test.QuickCheck.Property import Control.Applicative import Reactive.Banana.Test.Plumbing main = defaultMain [ testGroup "Simple" [ testModelMatch "id" id -- , testModelMatch "never1" never1 , testModelMatch "fmap1" fmap1 , testModelMatch "filter1" filter1 , testModelMatch "filter2" filter2 , testModelMatch "accumE1" accumE1 ] , testGroup "Complex" [ testModelMatch "counter" counter , testModelMatch "double" double , testModelMatch "sharing" sharing , testModelMatch "recursive1" recursive1 , testModelMatch "recursive2" recursive2 , testModelMatch "recursive3" recursive3 , testModelMatch "accumBvsE" accumBvsE ] , testGroup "Dynamic Event Switching" [ testModelMatch "observeE_id" observeE_id , testModelMatchM "initialB_immediate" initialB_immediate , testModelMatchM "initialB_recursive1" initialB_recursive1 , testModelMatchM "initialB_recursive2" initialB_recursive2 , testModelMatchM "dynamic_apply" dynamic_apply , testModelMatchM "switchE1" switchE1 , testModelMatchM "switchB_two" switchB_two ] -- TODO: -- * algebraic laws -- * larger examples -- * quickcheck ] {----------------------------------------------------------------------------- Testing ------------------------------------------------------------------------------} matchesModel :: (Show b, Eq b) => (Event a -> Moment (Event b)) -> [a] -> IO Bool matchesModel f xs = do bs1 <- return $ interpretModel f (singletons xs) bs2 <- interpretGraph f (singletons xs) -- bs3 <- interpretFrameworks f xs let bs = [bs1,bs2] let b = all (==bs1) bs when (not b) $ mapM_ print bs return b singletons = map Just -- test whether model matches testModelMatchM :: (Show b, Eq b) => String -> (Event Int -> Moment (Event b)) -> Test testModelMatchM name f = testCase name $ assert $ matchesModel f [1..8::Int] testModelMatch name f = testModelMatchM name (return . f) -- individual tests for debugging testModel :: (Event Int -> Event b) -> [Maybe b] testModel f = interpretModel (return . f) $ singletons [1..8::Int] testGraph f = interpretGraph (return . f) $ singletons [1..8::Int] testModelM f = interpretModel f $ singletons [1..8::Int] testGraphM f = interpretGraph f $ singletons [1..8::Int] {----------------------------------------------------------------------------- Tests ------------------------------------------------------------------------------} never1 :: Event Int -> Event Int never1 = const never fmap1 = fmap (+1) filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing) filter1 = filterE (>= 3) filter2 = filterE (>= 3) . fmap (subtract 1) accumE1 = accumE 0 . ((+1) <$) counter e = applyE (pure const <*> bcounter) e where bcounter = accumB 0 $ fmap (\_ -> (+1)) e merge e1 e2 = unionWith (++) (list e1) (list e2) where list = fmap (:[]) double e = merge e e sharing e = merge e1 e1 where e1 = filterE (< 3) e recursive1 e1 = e2 where e2 = applyE b e1 b = (+) <$> stepperB 0 e2 recursive2 e1 = e2 where e2 = applyE b e1 b = (+) <$> stepperB 0 e3 e3 = applyE (id <$> b) e1 -- actually equal to e2 type Dummy = Int -- counter that can be decreased as long as it's >= 0 recursive3 :: Event Dummy -> Event Int recursive3 edec = applyE (const <$> bcounter) ecandecrease where bcounter = accumB 4 $ (subtract 1) <$ ecandecrease ecandecrease = whenE ((>0) <$> bcounter) edec -- test accumE vs accumB accumBvsE :: Event Dummy -> Event [Int] accumBvsE e = merge e1 e2 where e1 = accumE 0 ((+1) <$ e) e2 = let b = accumB 0 ((+1) <$ e) in applyE (const <$> b) e observeE_id = observeE . fmap return -- = id initialB_immediate e = do x <- initialB (stepper 0 e) return $ x <$ e initialB_recursive1 e1 = mdo _ <- initialB b let b = stepper 0 e1 return $ b <@ e1 -- NOTE: This test case tries to reproduce a situation -- where the value of a latch is used before the latch was created. -- This was relevant for the CRUD example, but I can't find a way -- to make it smaller right now. Oh well. initialB_recursive2 e1 = mdo x <- initialB b let bf = const x <$ stepper 0 e1 let b = stepper 0 $ (bf <*> b) <@ e1 return $ b <@ e1 dynamic_apply e = do mb <- trimB $ stepper 0 e return $ observeE $ (initialB =<< mb) <$ e -- = stepper 0 e <@ e switchE1 e = do me <- trimE e return $ switchE $ me <$ e switchB_two e = do mb0 <- trimB $ stepper 0 $ filterE even e mb1 <- trimB $ stepper 1 $ filterE odd e b0 <- mb0 let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e return $ b <@ e reactive-banana-0.7.1.3/src/Reactive/Banana/Experimental/0000755000000000000000000000000012176662610021243 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana/Experimental/Calm.hs0000644000000000000000000001024312176662610022453 0ustar0000000000000000{----------------------------------------------------------------------------- Reactive Banana ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} module Reactive.Banana.Experimental.Calm ( -- * Synopsis -- | Experimental module: API change very likely. -- -- 'Event' type that disallows simultaneous event occurrences. -- -- The combinators behave essentially as their counterparts -- in "Reactive.Banana.Combinators". -- * Main types Event, Behavior, collect, fromCalm, interpret, -- * Core Combinators module Control.Applicative, never, unionWith, filterE, accumE, apply, stepper, -- * Derived Combinators -- ** Filtering filterJust, -- ** Accumulation -- $Accumulation. accumB, mapAccum, -- ** Apply class Reactive.Banana.Combinators.Apply(..), ) where import Control.Applicative import Control.Monad import Data.Maybe (listToMaybe) import qualified Reactive.Banana.Combinators as Prim import qualified Reactive.Banana.Combinators {----------------------------------------------------------------------------- Main types ------------------------------------------------------------------------------} newtype Event t a = E { unE :: Prim.Event t a } type Behavior t = Reactive.Banana.Combinators.Behavior t -- | Convert event with possible simultaneous occurrences -- into an 'Event' with a single occurrence. collect :: Reactive.Banana.Combinators.Event t a -> Event t [a] collect = E . Prim.collect -- | Convert event with single occurrences into -- event with possible simultaneous occurrences fromCalm :: Event t a -> Reactive.Banana.Combinators.Event t a fromCalm = unE singleton x = [x] -- | Interpretation function. -- Useful for testing. interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b] interpret f xs = map listToMaybe <$> Prim.interpret (unE . f . E) (map singleton xs) {----------------------------------------------------------------------------- Core Combinators ------------------------------------------------------------------------------} -- | Event that never occurs. -- Think of it as @never = []@. never :: Event t a never = E $ Prim.never -- | Merge two event streams of the same type. -- Combine simultaneous values if necessary. unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a unionWith f e1 e2 = E $ Prim.unionWith f (unE e1) (unE e2) -- | Allow all events that fulfill the predicate, discard the rest. filterE :: (a -> Bool) -> Event t a -> Event t a filterE p = E . Prim.filterE p . unE -- | Construct a time-varying function from an initial value and -- a stream of new values. stepper :: a -> Event t a -> Behavior t a stepper x e = Prim.stepper x (unE e) -- | The 'accumE' function accumulates a stream of events. accumE :: a -> Event t (a -> a) -> Event t a accumE acc = E . Prim.accumE acc . unE -- | Apply a time-varying function to a stream of events. apply :: Behavior t (a -> b) -> Event t a -> Event t b apply b = E . Prim.apply b . unE instance Functor (Event t) where fmap f = E . fmap f . unE {----------------------------------------------------------------------------- Derived Combinators ------------------------------------------------------------------------------} -- | Keep only the 'Just' values. -- Variant of 'filterE'. filterJust :: Event t (Maybe a) -> Event t a filterJust = E . Prim.filterJust . unE -- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. -- It starts with an initial value and combines it with incoming events. accumB :: a -> Event t (a -> a) -> Behavior t a accumB acc = Prim.accumB acc . unE -- $Accumulation. -- Note: all accumulation functions are strict in the accumulated value! -- acc -> (x,acc) is the order used by 'unfoldr' and 'State'. -- | Efficient combination of 'accumE' and 'accumB'. mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) mapAccum acc ef = let (e,b) = Prim.mapAccum acc (unE ef) in (E e, b) instance Reactive.Banana.Combinators.Apply (Behavior t) (Event t) where (<@>) = apply reactive-banana-0.7.1.3/src/Reactive/Banana/Frameworks/0000755000000000000000000000000012176662610020726 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana/Frameworks/AddHandler.hs0000644000000000000000000000376312176662610023261 0ustar0000000000000000{----------------------------------------------------------------------------- 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) reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/0000755000000000000000000000000012176662610020362 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/Cached.hs0000644000000000000000000000424412176662610022071 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/DependencyGraph.hs0000644000000000000000000000511312176662610023756 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/EventBehavior1.hs0000644000000000000000000001332012176662610023537 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/InputOutput.hs0000644000000000000000000000514312176662610023241 0ustar0000000000000000{----------------------------------------------------------------------------- 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) reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/Phantom.hs0000644000000000000000000000131112176662610022320 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE EmptyDataDecls, FlexibleInstances #-} module Reactive.Banana.Internal.Phantom ( -- * Synopsis -- | Classes used to constrain the phantom type @t@ in the 'Moment' type. -- * Documentation Frameworks, FrameworksD, ) where -- | Class constraint on the type parameter @t@ of the 'Moment' monad. -- -- Indicates that we can add input and output to an event network. class Frameworks t -- | Data type for discharging the 'Frameworks' constraint. data FrameworksD instance Frameworks (FrameworksD,t)reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/PulseLatch0.hs0000644000000000000000000004457312176662610023057 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Internal/Types2.hs0000644000000000000000000000375212176662610022113 0ustar0000000000000000{----------------------------------------------------------------------------- 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 reactive-banana-0.7.1.3/src/Reactive/Banana/Test/0000755000000000000000000000000012176662610017525 5ustar0000000000000000reactive-banana-0.7.1.3/src/Reactive/Banana/Test/Plumbing.hs0000644000000000000000000000755712176662610021654 0ustar0000000000000000{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -- * Synopsis -- | Merge model and implementation into a single type. Not pretty. module Reactive.Banana.Test.Plumbing where import Control.Applicative import Control.Monad (liftM) 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 {----------------------------------------------------------------------------- Types as pairs ------------------------------------------------------------------------------} data Event a = E (X.Event a) (Y.Event a) data Behavior a = B (X.Behavior a) (Y.Behavior a) data Moment a = M (X.Moment a) (Y.Moment a) -- pair extractions fstE (E x _) = x; sndE (E _ y) = y fstB (B x _) = x; sndB (B _ y) = y fstM (M x _) = x; sndM (M _ y) = y -- partial embedding functions ex x = E x undefined; ey y = E undefined y bx x = B x undefined; by y = B undefined y mx x = M x undefined; my y = M undefined y -- interpretation interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b] interpretModel f = X.interpret (fmap fstE . fstM . f . ex) interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b] interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey) {----------------------------------------------------------------------------- Primitive combinators ------------------------------------------------------------------------------} never = E X.never Y.never filterJust (E x y) = E (X.filterJust x) (Y.filterJust y) unionWith f (E x1 y1) (E x2 y2) = E (X.unionWith f x1 x2) (Y.unionWith f y1 y2) mapE f (E x y) = E (X.mapE f x) (Y.mapE f y) applyE ~(B x1 y1) (E x2 y2) = E (X.applyE x1 x2) (Y.applyE y1 y2) accumE a (E x y) = E (X.accumE a x) (Y.accumE a y) instance Functor Event where fmap = mapE stepper = stepperB stepperB a (E x y) = B (X.stepperB a x) (Y.stepperB a y) pureB a = B (X.pureB a) (Y.pureB a) applyB (B x1 y1) (B x2 y2) = B (X.applyB x1 x2) (Y.applyB y1 y2) mapB f (B x y) = B (X.mapB f x) (Y.mapB f y) instance Functor Behavior where fmap = mapB instance Applicative Behavior where pure = pureB; (<*>) = applyB instance Functor Moment where fmap = liftM instance Monad Moment where return a = M (return a) (return a) (M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g) instance MonadFix Moment where mfix f = M (mfix fx) (mfix fy) where fx a = let M x _ = f a in x fy a = let M _ y = f a in y trimE :: Event a -> Moment (Moment (Event a)) trimE (E x y) = M (fmap (fmap ex . mx) $ X.trimE x) (fmap (fmap ey . my) $ Y.trimE y) trimB :: Behavior a -> Moment (Moment (Behavior a)) trimB (B x y) = M (fmap (fmap bx . mx) $ X.trimB x) (fmap (fmap by . my) $ Y.trimB y) initialB ~(B x y) = M (X.initialB x) (Y.initialB y) observeE :: Event (Moment a) -> Event a observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y) switchE :: Event (Moment (Event a)) -> Event a switchE (E x y) = E (X.switchE $ X.mapE (fstM . fmap fstE) x) (Y.switchE $ Y.mapE (sndM . fmap sndE) y) switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a switchB (B x y) (E xe ye) = B (X.switchB x $ X.mapE (fstM . fmap fstB) xe) (Y.switchB y $ Y.mapE (sndM . fmap sndB) ye) {----------------------------------------------------------------------------- Derived combinators ------------------------------------------------------------------------------} accumB acc = stepperB acc . accumE acc whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b) b <@ e = applyE (const <$> b) e