reactive-banana 0.4.3.2 → 0.5.0.0

raw patch · 17 files changed

+1913/−1288 lines, 17 filesdep +fclabelsdep +hashabledep +unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: fclabels, hashable, unordered-containers

API changes (from Hackage documentation)

Files

• doc/examples/ActuatePause.hs +1/−1
• doc/examples/SlotMachine.hs +13/−12
• reactive-banana.cabal +24/−29
• src/Reactive/Banana.hs +4/−14
• src/Reactive/Banana/Combinators.hs +318/−0
• src/Reactive/Banana/Experimental/Calm.hs +131/−0
• src/Reactive/Banana/Frameworks.hs +403/−0
• src/Reactive/Banana/Implementation.hs +0/−371
• src/Reactive/Banana/Incremental.hs +0/−118
• src/Reactive/Banana/Internal/AST.hs +222/−0
• src/Reactive/Banana/Internal/InputOutput.hs +91/−0
• src/Reactive/Banana/Internal/Model.hs +141/−0
• src/Reactive/Banana/Internal/PushGraph.hs +410/−0
• src/Reactive/Banana/Internal/TotalOrder.hs +123/−0
• src/Reactive/Banana/Model.hs +0/−290
• src/Reactive/Banana/PushIO.hs +0/−430
• src/Reactive/Banana/Tests.hs +32/−23

@@ -11,7 +11,7 @@ import Debug.Trace import Data.IORef -import Reactive.Banana as R+import Reactive.Banana   main :: IO ()

@@ -3,6 +3,8 @@          Example: Slot machine ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub)@@ -18,7 +20,7 @@ main = do     displayHelpMessage     sources <- makeSources-    network <- setupNetwork sources+    network <- compile $ setupNetwork sources     actuate network     eventLoop sources @@ -82,9 +84,8 @@   -- Set up the program logic in terms of events and behaviors.-setupNetwork :: (EventSource (), EventSource ()) -> IO EventNetwork-setupNetwork (escoin,esplay) = compile $ do-+setupNetwork :: forall t. (EventSource (), EventSource ()) -> NetworkDescription t ()+setupNetwork (escoin,esplay) = do     -- initial random number generator     initialStdGen <- liftIO $ newStdGen @@ -99,8 +100,8 @@         -- 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 Money-        ecredits :: Event Money+        bcredits :: Behavior t Money+        ecredits :: Event t Money         (ecredits, bcredits) = mapAccum 0 . fmap (\f x -> (f x,f x)) $             ((addCredit <$ ecoin)             `union` (removeCredit <$ edoesplay)@@ -113,20 +114,20 @@         addWin Triple = (+20)                  -- Event: does the player have enough money to play the game?-        emayplay :: Event Bool+        emayplay :: Event t Bool         emayplay = apply ((\credits _ -> credits > 0) <$> bcredits) eplay                  -- Event: player has enough coins and plays-        edoesplay :: Event ()+        edoesplay :: Event t ()         edoesplay = () <$ filterE id  emayplay         -- Event: event that fires when the player doesn't have enough money-        edenied   :: Event ()+        edenied   :: Event t ()         edenied   = () <$ filterE not emayplay                           -- State: random number generator-        bstdgen :: Behavior StdGen-        eroll   :: Event Reels+        bstdgen :: Behavior t StdGen+        eroll   :: Event t Reels         -- accumulate the random number generator while rolling the reels         (eroll, bstdgen) = mapAccum initialStdGen (roll <$> edoesplay)         @@ -140,7 +141,7 @@             (z3,gen3) = random gen2                  -- Event: it's a win!-        ewin :: Event 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

@@ -1,32 +1,18 @@ Name:                reactive-banana-Version:             0.4.3.2-Synopsis:            Small but solid library for-                     functional reactive programming (FRP).+Version:             0.5.0.0+Synopsis:            Practical library for functional reactive programming (FRP). Description:         -    A small but solid library for functional reactive programming (FRP).-    .-    The current focus of this library is to implement-    a subset of the semantic model for functional reactive programming-    pioneered by Conal Elliott.-    .-    Moreover, this library can hooked into /any/-    existing event-based framework.-    It is especially useful in conjunction with existing-    GUI frameworks like @wxHaskell@ or @gtk2hs@.+    Reactive-banana is a practical library for Functional Reactive Programming (FRP).     .-    This also means that your code can be a mix of FRP and imperative parts.-    Bored of programming imperative GUIs? Write some parts with FRP!-    Don't know how to express something with FRP?-    Switch back to imperative style!+    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 spagethetti code commonly used in traditional GUI technologies.     .-    In the spectrum of possible FRP implementations,-    this one features simple semantics but modest expressivity.-    Predicting space & time usage should be easy.+    See the project homepage <http://haskell.org/haskellwiki/Reactive-banana>+    for a more detailed introduction and features.     .     Stability forecast:-    Known inefficiencies that will be addressed.     No semantic bugs expected.-    Significant API changes are likely in future versions.+    Significant API changes are likely in future versions,+    though the main interface is beginning to stabilize.  Homepage:            http://haskell.org/haskellwiki/Reactive-banana License:             BSD3@@ -43,7 +29,8 @@  Library     hs-source-dirs:     src-    extensions:         TypeFamilies, FlexibleContexts,+    extensions:+                        TypeFamilies, FlexibleContexts,                         FlexibleInstances, EmptyDataDecls,                         GADTs, BangPatterns, TupleSections,                         Rank2Types, NoMonomorphismRestriction,@@ -52,13 +39,21 @@         base >= 4.2 && < 5, containers >= 0.3 && < 0.5,         transformers == 0.2.*,         QuickCheck >= 1.2 && < 2.5,-        vault == 0.1.*-    exposed-modules:    Reactive.Banana,-                        Reactive.Banana.Incremental,-                        Reactive.Banana.Model,-                        Reactive.Banana.Implementation,+        vault == 0.1.*, unordered-containers == 0.2.*, hashable == 1.1.*,+        fclabels == 1.1.*+    exposed-modules:+                        Reactive.Banana,+                        Reactive.Banana.Combinators,+                        Reactive.Banana.Frameworks,+                        Reactive.Banana.Experimental.Calm,+                        Reactive.Banana.Internal.Model+    other-modules:+                        Reactive.Banana.Internal.AST,+                        Reactive.Banana.Internal.InputOutput,+                        Reactive.Banana.Internal.PushGraph,+                        Reactive.Banana.Internal.TotalOrder,                         Reactive.Banana.Tests-    other-modules:      Reactive.Banana.PushIO+  Source-repository head     type:               git

@@ -5,19 +5,9 @@ ------------------------------------------------------------------------------}  module Reactive.Banana (-    module Reactive.Banana.Incremental,-    module Reactive.Banana.Model,-    module Reactive.Banana.Implementation,--    Event, Behavior, Discrete,+    module Reactive.Banana.Combinators,+    module Reactive.Banana.Frameworks,     ) where -import Reactive.Banana.Incremental hiding (Discrete)-import qualified Reactive.Banana.Incremental as Polymorph-import Reactive.Banana.Model hiding (interpret, Event, Behavior)-import qualified Reactive.Banana.Model as Polymorph-import Reactive.Banana.Implementation--type Event    = Polymorph.Event PushIO-type Behavior = Polymorph.Behavior PushIO-type Discrete = Polymorph.Discrete PushIO+import Reactive.Banana.Combinators+import Reactive.Banana.Frameworks

@@ -0,0 +1,318 @@+{-----------------------------------------------------------------------------+    Reactive Banana+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, TupleSections, FlexibleInstances #-}++module Reactive.Banana.Combinators (+    -- * Synopsis+    -- | Combinators for building event graphs.+    +    -- * Introduction+    -- $intro1+    Event(..), Behavior(..),+    -- $intro2+    interpretModel, interpretPushGraph,+    +    -- * Core Combinators+    module Control.Applicative,+    module Data.Monoid,+    never, union, 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)+import Data.Monoid (Monoid(..))++import Reactive.Banana.Internal.InputOutput+import qualified Reactive.Banana.Internal.AST as AST+import qualified Reactive.Banana.Internal.Model as Model+import Reactive.Banana.Internal.PushGraph++{-----------------------------------------------------------------------------+    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 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 :: AST.Event AST.Expr [a] }+    -- ^ (Constructor exported for internal use only.)++{-| @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 :: AST.Behavior AST.Expr a }+    -- ^ (Constructor exported for internal use only.)++{-$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 with model implementation.+-- Useful for testing.+interpretModel :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]+interpretModel f xs =+    map toList <$> Model.interpretModel (unE . f . E) (map Just xs)++-- | Interpret with push-based implementation.+-- Useful for testing.+interpretPushGraph :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]+interpretPushGraph f xs = do+    i <- newInputChannel+    automaton <- compileToAutomaton (unE . f . E $ AST.inputE i)+    map toList <$> unfoldAutomaton automaton i xs++toList :: Maybe [a] -> [a]+toList Nothing   = []+toList (Just xs) = xs++{-----------------------------------------------------------------------------+    Basic combinators++    Implemented in terms of Reactive.Banana.Internal.AST+------------------------------------------------------------------------------}+singleton :: a -> [a]+singleton x = [x]++-- | Event that never occurs.+-- Think of it as @never = []@.+never    :: Event t a+never = E $ singleton <$> AST.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 $ AST.unionWith (++) (unE e1) (unE e2)++-- | 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 = E . AST.filterE (not . null) . (filter p <$>) . unE++-- | 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 $ singleton <$> unE e++-- | Emit simultaneous event occurrences.+-- Up to strictness, we have+--+-- > spill . collect = id+spill :: Event t [a] -> Event t a+spill e = E $ concat <$> unE e++-- | 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 $ AST.stepperB x (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 . fmap concatenate . unE+    where+    concatenate :: [a -> a] -> a -> ([a],a)+    concatenate fs acc = (tail values, last values)+        where values = scanl' (flip ($)) acc fs++    mapAccumE :: s -> AST.Event AST.Expr (s -> (a,s)) -> AST.Event AST.Expr a+    mapAccumE acc = fmap fst . AST.accumE (undefined,acc) . fmap (. 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 $ AST.applyE (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@.++-}++instance Monoid (Event t (a -> a)) where+    mempty  = never+    mappend = unionWith (flip (.))++instance Functor (Event t) where+    fmap f e = E $ (map f) <$> (unE e)++instance Applicative (Behavior t) where+    pure x = B $ AST.pureB x+    bf <*> bx = B $ AST.applyB (unB bf) (unB bx)++instance Functor (Behavior t) where+    fmap = liftA++{-----------------------------------------------------------------------------+    Derived Combinators+------------------------------------------------------------------------------}+-- | Keep only the 'Just' values.+-- Variant of 'filterE'.+filterJust :: Event t (Maybe a) -> Event t a+filterJust = fmap (maybe err id) . filterE isJust+    where err = error "Reactive.Banana.Model.filterJust: Internal error. :("++-- | 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.+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 $ AST.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++

@@ -0,0 +1,131 @@+{-----------------------------------------------------------------------------+    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,+    interpretModel, interpretPushGraph,+    +    -- * Core Combinators+    module Control.Applicative,+    never, unionWith, filterE, accumE,+    apply, stepper,+    -- $classes+    +    -- * 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]++-- | Interpret with model implementation.+-- Useful for testing.+interpretModel :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b]+interpretModel f xs =+    map listToMaybe <$> Prim.interpretModel (unE . f . E) (map singleton xs)++-- | Interpret with push-based implementation.+-- Useful for testing.+interpretPushGraph :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b]+interpretPushGraph f xs =+    map listToMaybe <$> Prim.interpretPushGraph (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++

@@ -0,0 +1,403 @@+{-----------------------------------------------------------------------------+    Reactive Banana+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}++module Reactive.Banana.Frameworks (+    -- * Synopsis+    -- | Build event networks using existing event-based frameworks and run them.+    +    -- * Simple use+    interpret, interpretAsHandler,++    -- * Building event networks with input/output+    -- $build+    NetworkDescription, compile,+    AddHandler, fromAddHandler, fromChanges, fromPoll,+    reactimate, initial, changes,+    liftIO, liftIOLater,+    +    -- * Running event networks+    EventNetwork, actuate, pause,+    +    -- * Utilities+    -- $utilities+    newAddHandler, newEvent,+    ) where++import Control.Applicative+import Control.Arrow (second)+import Control.Concurrent+import Control.Monad+import Control.Monad.Fix       (MonadFix(..))+import Control.Monad.IO.Class  (MonadIO(..))+import Control.Monad.Trans.RWS++import Data.Dynamic (Typeable)+import Data.IORef+import Data.List (nub)+import Data.Monoid++import qualified Data.HashMap.Strict as Map++import Reactive.Banana.Internal.InputOutput+import Reactive.Banana.Combinators+import qualified Reactive.Banana.Internal.AST as AST+import qualified Reactive.Banana.Internal.PushGraph as Implementation++type Map = Map.HashMap++{-----------------------------------------------------------------------------+    AST specific functions+------------------------------------------------------------------------------}+inputE :: InputChannel [a] -> Event t a+inputE = E . AST.inputE++{-----------------------------------------------------------------------------+    NetworkDescription, setting up event networks+------------------------------------------------------------------------------}+{-$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?++    This "Reactive.Banana.Implementation" module allows you to obtain /input/ events+    from external sources+    and it allows you perform /output/ in reaction to events.+    +    In constrast, the functions from "Reactive.Banana.Model" 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 'NetworkDescription' 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. NetworkDescription 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, you use 'fromAddHandler' to obtain /input/ events.+    The library uses this to register event handlers+    with your event-based framework.+    +    To animate /output/ events, use the 'reactimate' function.++-}++type AddHandler'     = AddHandler InputValue+type Preparations t  =+    ( [Event t (IO ())]     -- reactimate outputs+    , [AddHandler']         -- fromAddHandler events +    , [IO InputValue]       -- fromPoll events+    , [IO ()]               -- liftIOLater+    )++-- | Monad for describing event networks.+-- +-- The 'NetworkDescription' monad is an instance of 'MonadIO',+-- so 'IO' is allowed inside.+-- +-- Note: The phantom type @t@ prevents you from smuggling+-- values of types 'Event' or 'Behavior'+-- outside the 'NetworkDescription' monad.+newtype NetworkDescription t a+    = Prepare { unPrepare :: RWST () (Preparations t) () IO a }++instance Monad (NetworkDescription t) where+    return  = Prepare . return+    m >>= k = Prepare $ unPrepare m >>= unPrepare . k+instance MonadIO (NetworkDescription t) where+    liftIO  = Prepare . liftIO+instance Functor (NetworkDescription t) where+    fmap f  = Prepare . fmap f . unPrepare+instance Applicative (NetworkDescription t) where+    pure    = Prepare . pure+    f <*> a = Prepare $ unPrepare f <*> unPrepare a+instance MonadFix (NetworkDescription t) where+    mfix f  = Prepare $ mfix (unPrepare . f)++{- | 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.++-}+reactimate :: Event t (IO ()) -> NetworkDescription t ()+reactimate e = Prepare $ tell ([e],[],[],[])++-- | 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 ())++-- | Input,+-- obtain an 'Event' from an 'AddHandler'.+--+-- When the event network is actuated,+-- this will register a callback function such that+-- an event will occur whenever the callback function is called.+fromAddHandler :: AddHandler a -> NetworkDescription t (Event t a)+fromAddHandler addHandler = Prepare $ do+    i <- liftIO $ newInputChannel+    let addHandler' k = addHandler $ k . toValue i . (\x -> [x])+    tell ([],[addHandler'],[],[])+    return $ inputE i++-- | Input,+-- obtain a 'Behavior' by frequently polling mutable data, like the current time.+--+-- The resulting 'Behavior' will be updated on whenever the event+-- network processes an input event.+--+-- This function is occasionally useful, but+-- the recommended way to obtain 'Behaviors' is by using 'fromChanges'.+-- +-- Ideally, the argument IO action just polls a mutable variable,+-- it should not perform expensive computations.+-- Neither should its side effects affect the event network significantly.+fromPoll :: IO a -> NetworkDescription t (Behavior t a)+fromPoll poll = Prepare $ do+    i <- liftIO $ newInputChannel+    let poll' = toValue i . (:[]) <$> poll+    tell ([],[],[poll'],[])+    initial <- liftIO $ poll+    return $ stepper initial (inputE i)++-- | Input,+-- obtain a 'Behavior' from an 'AddHandler' that notifies changes.+-- +-- This is essentially just an application of the 'stepper' combinator.+fromChanges :: a -> AddHandler a -> NetworkDescription 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)+changes :: Behavior t a -> NetworkDescription t (Event t a)+changes ~(B (AST.Pair _ (AST.Stepper x e))) = return $ E $ fmap (:[]) e++-- | Output,+-- observe the initial value contained in a 'Behavior'.+--+-- Similar to 'updates', this function is not well-defined,+-- but exists for reasons of efficiency.+initial :: Behavior t a -> NetworkDescription t a+initial ~(B (AST.Pair _ (AST.Stepper x e))) = return x++-- | Lift an 'IO' action into the 'NetworkDescription' monad,+-- but defer its execution until compilation time.+-- This can be useful for recursive definitions using 'MonadFix'.+liftIOLater :: IO () -> NetworkDescription t ()+liftIOLater m = Prepare $ tell ([],[],[],[m])++-- | Compile a 'NetworkDescription' into an 'EventNetwork'+-- that you can 'actuate', 'pause' and so on.+compile :: (forall t. NetworkDescription t ()) -> IO EventNetwork+compile (Prepare m) = do+    -- execute the NetworkDescription monad+    (_,_,(outputs,inputs,polls,liftIOs)) <- runRWST m () ()+    sequence_ liftIOs+    +    let -- union of all  reactimates+        E graph = foldr union never outputs+    +    automaton <- Implementation.compileToAutomaton graph+    +    -- allocate new variable for the automaton+    rautomaton <- newEmptyMVar+    putMVar rautomaton automaton+    +    let -- run the graph on a single input value+        run :: InputValue -> IO ()+        run input = do+            -- takeMVar  makes sure that event graph updates are sequential.+            automaton  <- takeMVar rautomaton+            -- poll mutable data+            pollValues <- sequence polls+            -- percolate inputs through event graph+            (reactimates,automaton') <- runStep automaton $ input:pollValues+            putMVar rautomaton automaton'+            -- Run corresponding IO actions afterwards.+            -- Under certain circumstances, they can *interleave*.+            case reactimates of+                Just actions -> sequence_ actions+                Nothing      -> return ()+    +        -- register event handlers+        register :: IO (IO ())+        register = fmap sequence_ . sequence . map ($ run) $ inputs++    makeEventNetwork register+++{-----------------------------------------------------------------------------+    Running event networks+------------------------------------------------------------------------------}+-- | Data type that represents a compiled event network.+-- It may be paused or already running.+data EventNetwork = 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 :: IO (),+    +    -- | 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 :: IO ()+    } deriving (Typeable)++-- Make an event network from a function that registers all event handlers+makeEventNetwork :: IO (IO ()) -> IO EventNetwork+makeEventNetwork register = do+    let nop = return ()+    unregister <- newIORef nop+    let+        actuate = register >>= writeIORef unregister+        pause   = readIORef unregister >>= id >> writeIORef unregister nop+    return $ EventNetwork actuate pause+++{-----------------------------------------------------------------------------+    Simple use+------------------------------------------------------------------------------}+-- | Simple way to run an event graph. Very useful for testing.+-- Uses the efficient push-driven implementation.+interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]]+interpret 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 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 <- 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)+++-- | 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 :: NetworkDescription t (Event t a, a -> IO ())+newEvent = do+    (addHandler, fire) <- liftIO $ newAddHandler+    e <- fromAddHandler addHandler+    return (e,fire)

@@ -1,371 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{------------------------------------------------------------------------------    Reactive Banana-    -    Linking the push-based implementation to an event-based framework-------------------------------------------------------------------------------}-module Reactive.Banana.Implementation (-    -- * Synopsis-    -- | Build event networks using existing event-based frameworks-    --   and run them.-    -    -- * Simple use-    PushIO, interpret, interpretAsHandler,--    -- * Building event networks with input/output-    -- $build-    NetworkDescription, compile,-    AddHandler, fromAddHandler, fromPoll, reactimate, liftIO, liftIOLater,-    -    -- * Running event networks-    EventNetwork, actuate, pause,-    -    -- * Utilities-    -- $utilities-    newAddHandler,-    -    module Data.Dynamic, -- remove this when bumping to 0.5-    ) where--import Control.Applicative-import Control.Arrow (second)-import Control.Concurrent-import Control.Monad-import Control.Monad.Fix       (MonadFix(..))-import Control.Monad.IO.Class  (MonadIO(..))-import Control.Monad.Trans.RWS--import Data.Dynamic-import Data.IORef-import Data.List (nub)-import Data.Monoid-import qualified Data.Map as Map-import Data.Unique--import Reactive.Banana.PushIO hiding (compile)-import qualified Reactive.Banana.PushIO as Implementation-import qualified Reactive.Banana.Model as Model--{------------------------------------------------------------------------------    PushIO specific functions-------------------------------------------------------------------------------}-type Flavor  = Implementation.PushIO--poll :: IO a -> Model.Behavior Flavor a-poll = behavior . Poll--input :: Channel -> Key a -> Model.Event Flavor a-input c = event . Input c--compileHandlers :: Model.Event Flavor (IO ()) -> IO [(Channel, Universe -> IO ())]-compileHandlers graph = do-    -- compile event graph-    let graph' = Implementation.unEvent graph-    (paths1,cache) <- Implementation.compile (invalidRef, Reactimate graph')--    -- prepare threading the cache as state-    rcache <- newEmptyMVar-    putMVar rcache cache-    let -- run a single path-        run m = do-            -- takeMVar  makes sure that event graph updates are sequential.-            cache <- takeMVar rcache-            (reactimates,cache') <- runRun m cache-            putMVar rcache cache'-            -- However, the corresponding IO actions are run afterwards,-            -- and under certain circumstances, they can *interleave*.-            reactimates-         -        appendReactimates-            :: [Universe -> Run (IO ())]-            -> (Universe -> Run (IO ()))-        appendReactimates ps x = do-            reactimates <- sequence $ map ($ x) ps-            return $ sequence_ reactimates-            -        paths2 = map (second $ (run .) . appendReactimates) $ groupByChannel paths1-    -    return paths2----- FIXME: make this faster-groupByChannel :: [(Channel, a)] -> [(Channel, [a])]-groupByChannel xs = [(i, [x | (j,x) <- xs, i == j]) | i <- channels]-    where channels = nub . map fst $ xs--{------------------------------------------------------------------------------    NetworkDescription, setting up event networks-------------------------------------------------------------------------------}-{-$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?--    This "Reactive.Banana.Implementation" module allows you to obtain /input/ events-    from external sources-    and it allows you perform /output/ in reaction to events.-    -    In constrast, the functions from "Reactive.Banana.Model" 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 'NetworkDescription' 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->   ...->->   -- build the event network->   network <- compile $ do->       -- input: obtain  Event  from functions that register event handlers->       emouse    <- fromAddHandler $ registerMouseEvent window->       ekeyboard <- fromAddHandler $ registerKeyEvent window->       -- input: obtain  Behavior  from mutable data by polling->       btext     <- fromPoll       $ getTextValue editBox->       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->->   -- register handlers and start producing outputs->   actuate network--    In short, you use 'fromAddHandler' to obtain /input/ events.-    The library uses this to register event handlers-    with your event-based framework.-    -    To animate /output/ events, use the 'reactimate' function.---}--type AddHandler'  = (Channel, AddHandler Universe)-type Preparations = ([Model.Event Flavor (IO ())], [AddHandler'], [IO ()])---- | Monad for describing event networks.--- --- The 'NetworkDescription' monad is an instance of 'MonadIO',--- so 'IO' is allowed inside.--- --- Note: It is forbidden to smuggle values of types 'Event' or 'Behavior'--- outside the 'NetworkDescription' monad. This shouldn't be possible by default,--- but you might get clever and use 'IORef' to circumvent this.--- Don't do that, it won't work and also has a 99,98% chance of --- destroying the earth by summoning time-traveling zygohistomorphisms.-newtype NetworkDescription a = Prepare { unPrepare :: RWST () Preparations Channel IO a }--instance Monad (NetworkDescription) where-    return  = Prepare . return-    m >>= k = Prepare $ unPrepare m >>= unPrepare . k-instance MonadIO (NetworkDescription) where-    liftIO  = Prepare . liftIO-instance Functor (NetworkDescription) where-    fmap f  = Prepare . fmap f . unPrepare-instance Applicative (NetworkDescription) where-    pure    = Prepare . pure-    f <*> a = Prepare $ unPrepare f <*> unPrepare a-instance MonadFix (NetworkDescription) where-    mfix f  = Prepare $ mfix (unPrepare . f)--{- | 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.---}-reactimate :: Model.Event PushIO (IO ()) -> NetworkDescription ()-reactimate e = Prepare $ tell ([e], [], [])---- | 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 ())---- | Input,--- obtain an 'Event' from an 'AddHandler'.------ When the event network is actuated,--- this will register a callback function such that--- an event will occur whenever the callback function is called.-fromAddHandler :: AddHandler a -> NetworkDescription (Model.Event PushIO a)-fromAddHandler addHandler = Prepare $ do-        channel <- newChannel-        key     <- liftIO $ newUniverseKey-        let addHandler' k = addHandler $ k . toUniverse key-        tell ([], [(channel, addHandler')], [])-        return $ input channel key-    where-    newChannel = do c <- get; put $! c+1; return c---- | Input,--- obtain a 'Behavior' by polling mutable data, like mutable variables or GUI widgets.--- --- 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.--- --- Internally, the event network will take a snapshot of each mutable--- datum before processing an input event, so that the obtained behavior--- is well-defined. This snapshot is guaranteed to happen before--- any 'reactimate' is performed. The network may omit taking a snapshot altogether--- if the behavior is not needed.-fromPoll :: IO a -> NetworkDescription (Model.Behavior PushIO a)-fromPoll m = return $ poll m---- | Lift an 'IO' action into the 'NetworkDescription' monad,--- but defer its execution until compilation time.--- This can be useful for recursive definitions using 'MonadFix'.-liftIOLater :: IO () -> NetworkDescription ()-liftIOLater m = Prepare $ tell ([],[], [m])---- | Compile a 'NetworkDescription' into an 'EventNetwork'--- that you can 'actuate', 'pause' and so on.-compile :: NetworkDescription () -> IO EventNetwork-compile (Prepare m) = do-    (_,_,(outputs,inputs,liftIOs)) <- runRWST m () 0-    sequence_ liftIOs-    -    let -- union of all  reactimates-        graph = mconcat outputs :: Model.Event Flavor (IO ())-    paths <- compileHandlers graph-    -    let -- register event handlers-        register = fmap sequence_ . sequence . map snd . applyChannels inputs-                 $ paths-    makeEventNetwork register---- FIXME: make this faster-applyChannels :: [(Channel, a -> b)] -> [(Channel, a)] -> [(Channel, b)]-applyChannels fs xs =-    [(i, f x) | (i,f) <- fs, (j,x) <- xs, i == j]--{------------------------------------------------------------------------------    Running event networks-------------------------------------------------------------------------------}--- | Data type that represents a compiled event network.--- It may be paused or already running.-data EventNetwork = 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 :: IO (),-    -    -- | 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 :: IO ()-    } deriving (Typeable)---- Make an event network from a function that registers all event handlers-makeEventNetwork :: IO (IO ()) -> IO EventNetwork-makeEventNetwork register = do-    let nop = return ()-    unregister <- newIORef nop-    let-        actuate = register >>= writeIORef unregister-        pause   = readIORef unregister >>= id >> writeIORef unregister nop-    return $ EventNetwork actuate pause---{------------------------------------------------------------------------------    Simple use-------------------------------------------------------------------------------}--- | Simple way to run an event graph. Very useful for testing.-interpret :: (Model.Event PushIO a -> Model.Event PushIO b) -> [a] -> IO [[b]]-interpret 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-    :: (Model.Event PushIO a -> Model.Event PushIO 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 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 <- 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)-

@@ -1,118 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-    -    Derived data type, a hybrid between  Event  and  Behavior-------------------------------------------------------------------------------}-{-# LANGUAGE MultiParamTypeClasses #-}-module Reactive.Banana.Incremental (-    -- * Why a third type Discrete?-    -- $discrete-    -    -- * Discrete time-varying values-    Discrete, initial, changes, value, stepperD,-    accumD, applyD,-    ) where--import Control.Applicative-import Reactive.Banana.Model--{------------------------------------------------------------------------------    Data Type-------------------------------------------------------------------------------}-{-$discrete--In an ideal world, users of functional reactive programming would-only need to use the notions of 'Behavior' and 'Event',-the first corresponding to value that vary in time-and the second corresponding to a stream of event ocurrences.--However, there is the problem of /incremental updates/.-Ideally, users would describe, say, the value of a GUI text field-as a 'Behavior' and the reactive-banana implementation would figure-out how to map this onto the screen without needless redrawing.-In other words, the screen should only be updated when the behavior changes.--While this would be easy to implement in simple cases,-it may not always suit the user;-there are many different ways of implementing-/incremental computations/.-But I don't know a unified theory for them, so-I have decided that the reactive-banana will give-/explicit control over updates to the user/-in the form of specialized data types like 'Discrete',-and shall not attempt to bake experimental optimizations into the 'Behavior' type.--To sum it up:--* You get explicit control over updates (the 'changes' function),--* but you need to learn a third data type 'Discrete',-which almost duplicates the 'Behavior' type.--* Even though the type 'Behavior' is more fundamental,-you will probably use 'Discrete' more often.--That said, 'Discrete' is not a new primitive type,-but built from exising types and combinators;-you are encouraged to look at the source code.--If you are an FRP implementor, I encourage you to find a better solution.-But if you are a user, you may want to accept the trade-off for now.---}---- | Like 'Behavior', the type 'Discrete' denotes a value that varies in time.--- However, unlike 'Behavior',--- it also provides a stream of events that indicate when the value has changed.--- In other words, we can now observe updates.-data Discrete f a = D {-        -- | Initial value.-        initial :: a,-        -- | Event that records when the value changes.-        -- Simultaneous events may be pruned for efficiency reasons.-        changes :: Event f a,-        -- | Behavior corresponding to the value. It is always true that-        -- -        -- > value x = stepper (initial x) (changes x)-        value   :: Behavior f a-        }---- | Construct a discrete time-varying value from an initial value and --- a stream of new values.-stepperD :: FRP f => a -> Event f a -> Discrete f a-stepperD x e = D { initial = x, changes = calm e, value = stepper x e}-    where-    -- in case of simultaneous occurence: keep only the last event?-    calm = id---- | Accumulate a stream of events into a discrete time-varying value.-accumD :: FRP f => a -> Event f (a -> a) -> Discrete f a-accumD x = stepperD x . accumE x---- | Apply a discrete time-varying value to a stream of events.--- --- > applyD = apply . value-applyD :: FRP f => Discrete f (a -> b) -> Event f a -> Event f b-applyD = apply . value---- | Overloading 'applyD'-instance FRP f => Apply (Discrete f) (Event f) where-    (<@>) = applyD---- | Functor instance-instance FRP f => Functor (Discrete f) where-    fmap f r = stepperD (f $ initial r) $ fmap f (changes r)---- | Applicative instance-instance FRP f => Applicative (Discrete f) where-    pure x    = D { initial = x, changes = never, value = pure x }-    df <*> dx = stepperD b e-        where-        b = initial df $ initial dx-        e = uncurry ($) <$> pairs-        pairs = accumE (initial df, initial dx) $-            (left <$> changes df) `union` (right <$> changes dx)-        -        left  f (_,x) = (f,x)-        right x (f,_) = (f,x)-

@@ -0,0 +1,222 @@+{-----------------------------------------------------------------------------+    Reactive-Banana+------------------------------------------------------------------------------}+{-# LANGUAGE GADTs, TypeFamilies, TupleSections, EmptyDataDecls,+    TypeSynonymInstances, FlexibleInstances #-}++module Reactive.Banana.Internal.AST where+-- Abstract syntax tree and assorted data types.++import Control.Applicative+import qualified Data.Vault as Vault+import System.IO.Unsafe++import Data.Hashable++import Reactive.Banana.Internal.InputOutput++{-----------------------------------------------------------------------------+    Abstract syntax tree+------------------------------------------------------------------------------}+-- Type families allow us to support multiple tags in the AST+type family   Event    t :: * -> *+type family   Behavior t :: * -> *++-- | Constructors for events.+data EventD t :: * -> * where+    Never     :: EventD t a+    UnionWith :: (a -> a -> a) -> Event t a -> Event t a -> EventD t a+    FilterE   :: (a -> Bool) -> Event t a -> EventD t a+    ApplyE    :: Behavior t (a -> b) -> Event t a -> EventD t b+    AccumE    :: a -> Event t (a -> a) -> EventD t a+    +    InputE    :: InputChannel a   -> EventD t a   -- represent external inputs+    InputPure :: InputChannel (EventModel a)+              -> EventD t a                       -- input for model implementation++-- | Constructors for behaviors.+data BehaviorD t :: * -> * where+    Stepper :: a -> Event t a -> BehaviorD t a++    InputB :: InputChannel a -> BehaviorD t a -- represent external inputs ++{-----------------------------------------------------------------------------+    Observable sharing+    +    Each constructor is paired with a @Node@ value.+    The @Node@ serves as a unique identifier and stores various keys+    into various vaults.+------------------------------------------------------------------------------}+data Pair f g a = Pair !(f a) (g a)++fstPair :: Pair f g a -> f a+fstPair (Pair x y) = x++-- | Type index indicating expressions with observable sharing+data Expr+type instance Event    Expr = Pair Node (EventD    Expr)+type instance Behavior Expr = Pair Node (BehaviorD Expr)++-- smart constructor that handles observable sharing+shareE :: EventD Expr a -> Event Expr a+shareE e = pair+    where+    {-# NOINLINE pair #-}+    -- mention argument to prevent let-floating+    pair = unsafePerformIO (fmap (flip Pair e) newNode)++shareB :: BehaviorD Expr a -> Behavior Expr a+shareB b = pair+    where+    {-# NOINLINE pair #-}+    pair = unsafePerformIO (fmap (flip Pair b) newNode)++{-----------------------------------------------------------------------------+    Smart constructors and class instances+------------------------------------------------------------------------------}+unE = id; unB = id++{- Note:+There is a fundamental problem with using Unique's for observable sharing.++The problem is the following:++    module Test where ..+    module Implementation where never = sharedE $ Never+    module Data.Unique++Imagine that the  Test  module contains an expression that contains sharing.+The  never  value contains a constant  Unique , which is evaluated as+soon as you evaluate  Test.expression  .+Now, reload the  Test  module. This will reset the counter for Data.Unique,+but it will *not* reset the Unique that is already contained in  never ,+because the CAF  never  itself will not be reset. This invariably leads to+a  Unique  being reused, leading to a program crash.++We solve the problem in Reactive.Banana.InputOutput+by using a better implementation of  Unique .++-}+{- Note:++Another good reason for not sharing `never` is that +it is *polymorphic*. The shared value may be instantiated to different types,+which is really bad.++-}+never             = shareE $ Never++unionWith f e1 e2 = shareE $ UnionWith f (unE e1) (unE e2)+filterE p e       = shareE $ FilterE p (unE e)+applyE b e        = shareE $ ApplyE (unB b) (unE e)+accumE acc e      = shareE $ AccumE acc (unE e)+inputE i          = shareE $ InputE i+inputPure i       = shareE $ InputPure i++stepperB acc e    = shareB $ Stepper acc (unE e)+inputB i          = shareB $ InputB i++mapE f  = applyE (pureB f)+pureB x = stepperB x never++applyB :: Behavior Expr (a -> b) -> Behavior Expr a -> Behavior Expr b+applyB (Pair _ (Stepper f fe)) (Pair _ (Stepper 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)+applyB _ _ = error "TODO: Don't know what to do with external behaviors."++-- instance Functor (Event Expr) where+instance Functor (Pair Node (EventD Expr)) where+    fmap   = mapE+-- instance Functor (Behavior Expr) where+instance Functor (Pair Node (BehaviorD Expr)) where+    fmap f = applyB (pureB f)++{-----------------------------------------------------------------------------+    The 'Node' type is used for observable sharing and must be defined here.+------------------------------------------------------------------------------}+-- | A 'Node' represents a unique identifier for an expression.+-- It actually contains keys for various 'Vault'.+--+-- TODO: Make a special case for the 'Never' constructor,+-- which cannot be shared.+data Node a+    = Node+    { -- use for Reactive.Banana.Internal.PushGraph+      keyValue   :: !(Vault.Key a)+    , keyFormula :: !(Vault.Key (FormulaD Nodes a))+    , keyOrder   :: !Unique+      -- use for Reactive.Banana.Internal.Model+    , keyModelE  :: !(Vault.Key (EventModel a))+    , keyModelB  :: !(Vault.Key (BehaviorModel a))+    }++newNode :: IO (Node a)+newNode = Node+    <$> Vault.newKey <*> Vault.newKey <*> newUnique+    <*> Vault.newKey <*> Vault.newKey++{-----------------------------------------------------------------------------+    Reactive.Banana.Internal.Model+------------------------------------------------------------------------------}+-- we have to define the interpretation types here+type EventModel a    = [Maybe a]+data BehaviorModel a = StepperB a (EventModel a)++{-----------------------------------------------------------------------------+    Reactive.Banana.Internal.PushGraph+------------------------------------------------------------------------------}+data Nodes+type instance Event    Nodes = Node+type instance Behavior Nodes = Node++-- | Formula that represents events and behaviors as one entity+data FormulaD t a where+    E :: EventD t a    -> FormulaD t a+    B :: BehaviorD t a -> FormulaD t a++caseFormula :: (EventD t a -> c) -> (BehaviorD t a -> c) -> FormulaD t a -> c+caseFormula e b (E x) = e x+caseFormula e b (B x) = b x++type family Formula t :: * -> *+type instance Formula Expr  = Pair Node (FormulaD Expr)+type instance Formula Nodes = Node++-- Helper class for embedding polymorphically in the type index+class ToFormula t where+    -- e :: Event    t a -> Formula t a+    -- b :: Behavior t a -> Formula t a+    +    ee :: Event t a    -> SomeFormula t+    bb :: Behavior t a -> SomeFormula t++instance ToFormula Expr where+    ee (Pair node e1) = Exists (Pair node $ E e1)+    bb (Pair node b1) = Exists (Pair node $ B b1)++instance ToFormula Nodes where+    ee node = Exists node+    bb node = Exists node+++-- | Formula, existentially quantified over the result type+data SomeFormula t where+    Exists :: Formula t a -> SomeFormula t+type SomeNode = SomeFormula Nodes++-- instances to store  SomeNode  in efficient maps+instance Eq SomeNode where+    (Exists x) == (Exists y) = (keyOrder x) == (keyOrder y)+instance Hashable SomeNode where+    hash (Exists x) = hash (keyOrder x)++instance Eq (SomeFormula Expr) where+    (Exists (Pair x _)) == (Exists (Pair y _)) = (keyOrder x) == (keyOrder y)+instance Hashable (SomeFormula Expr) where+    hash (Exists (Pair x _)) = hash (keyOrder x)++

@@ -0,0 +1,91 @@+{-----------------------------------------------------------------------------+    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,++    -- * Uniques+    -- | Doesn't belong here, but we also have some stuff about uniques+    -- that we use for observable sharing.+    Unique, newUnique,+    ) where++import Control.Applicative+import Control.Exception (evaluate)++import qualified Data.Unique as Unique+import qualified Data.Vault  as Vault+import Data.Hashable+import System.Mem.StableName++{-----------------------------------------------------------------------------+    Better Uniques+------------------------------------------------------------------------------}+type ReallyUnique = StableName Unique.Unique+type Unique = ReallyUnique++-- instance Hashable Unique++newUnique :: IO Unique+newUnique = do+    x <- Unique.newUnique+    evaluate x+    makeStableName x++{-----------------------------------------------------------------------------+    Storing heterogenous input values+------------------------------------------------------------------------------}+type Channel  = ReallyUnique    -- 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 -> [a] -> IO [Maybe b]+unfoldAutomaton _    _ []     = return []+unfoldAutomaton auto i (x:xs) = do+    (b, auto) <- runStep auto $ [toValue i x]+    bs        <- unfoldAutomaton auto i xs+    return (b:bs)+    

@@ -0,0 +1,141 @@+{-----------------------------------------------------------------------------+    Reactive-Banana+------------------------------------------------------------------------------}+{-# LANGUAGE GADTs #-}+module Reactive.Banana.Internal.Model (+    -- * Synopsis+    -- | Model implementation of the abstract syntax tree.+    +    -- * Description+    -- $model++    -- Combinators+    -- Event(..), Behavior(..),+    -- never, filterE, unionWith, applyE, accumE, stepper,+   +    -- * Interpretation+    interpretModel,+    ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.State+import qualified Data.Vault as Vault++import qualified Reactive.Banana.Internal.AST as AST+import Reactive.Banana.Internal.InputOutput++{-$model++This module contains the model implementation for the primitive combinators+defined "Reactive.Banana.Internal.AST"+which in turn are the basis for the official combinators+documented in "Reactive.Banana.Combinators".++This module does not export any combinators,+you have to look at the source code to make use of it.+(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.+-}++{-----------------------------------------------------------------------------+    Combinators+------------------------------------------------------------------------------}+-- due to observable sharing, the types have to be imported from+-- the module Reactive.Banana.Internal.AST+type Event a    = AST.EventModel a     -- = [Maybe a]+type Behavior a = AST.BehaviorModel a  -- = StepperB a (Event a)++never :: Event a+never = repeat Nothing++filterE :: (a -> Bool) -> Event a -> Event a+filterE p = map (>>= \x -> if p x then Just x else Nothing)++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++applyE :: Behavior (a -> b) -> Event a -> Event b+applyE _                   []     = []+applyE (AST.StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs+    where+    step a (Nothing:b) = stepper a b+    step _ (Just a :b) = stepper 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) ++stepper :: a -> [Maybe a] -> Behavior a+stepper = AST.StepperB++{-----------------------------------------------------------------------------+    Interpretation, pays attention to observable sharing+------------------------------------------------------------------------------}+-- state monad for evaluation+type Eval = State Vault.Vault++-- | Interpret an event graph with the model implementation.+-- Mainly useful for testing library internals.+interpretModel+    :: (AST.Event AST.Expr a -> AST.Event AST.Expr b)+    -> Event a -> IO (Event b)+interpretModel f input = do+    i0 <- newInputChannel+    +    let+        evalE :: AST.EventD AST.Expr a -> Eval (Event a)+        evalE (AST.Never)             = return $ never+        evalE (AST.UnionWith f e1 e2) = unionWith f <$> goE e1 <*> goE e2+        evalE (AST.FilterE p e)       = filterE p   <$> goE e+        evalE (AST.ApplyE b e )       = applyE      <$> goB b  <*> goE e+        evalE (AST.AccumE x e )       = accumE x    <$> goE e+        evalE (AST.InputPure i)       =+            return $ maybe err id $ fromValue i (toValue i0 input)+            where err = error "Reactive.Banana.PushIO.interpretModel: internal error: Input"+        evalE _                       =+            error "Reactive.Banana.PushIO.interpretModel: internal error: E"++        evalB :: AST.BehaviorD AST.Expr a -> Eval (Behavior a)+        evalB (AST.Stepper x e) = stepper x <$> goE e+        evalB _                 =+            error "Reactive.Banana.PushIO.interpretModel: internal error: B"++        goE :: AST.Event AST.Expr a -> Eval (Event a)+        goE (AST.Pair node e) = do+            values <- get+            case Vault.lookup (AST.keyModelE node) values of+                Nothing -> mfix $ \v -> do+                    modify $ Vault.insert (AST.keyModelE node) v+                    evalE e+                Just v  -> return v++        goB :: AST.Behavior AST.Expr a -> Eval (Behavior a)+        goB (AST.Pair node b) = do+            values <- get+            case Vault.lookup (AST.keyModelB node) values of+                Nothing -> mfix $ \v -> do+                    modify $ Vault.insert (AST.keyModelB node) v+                    evalB b+                Just v  -> return v+    +    return $+        zipWith const+            (evalState (goE $ f $ AST.inputPure i0) Vault.empty)+            input+

@@ -0,0 +1,410 @@+{-----------------------------------------------------------------------------+    Reactive-Banana+------------------------------------------------------------------------------}+{-# LANGUAGE GADTs, TypeFamilies, RankNTypes, TypeOperators,+             TypeSynonymInstances, FlexibleInstances,+             ScopedTypeVariables #-}++module Reactive.Banana.Internal.PushGraph (+    -- * Synopsis+    -- | Push-driven implementation.++    compileToAutomaton+    ) where++import Control.Applicative+import Control.Arrow (first)+import Control.Category+import Prelude hiding ((.),id)++import Data.Label+import Data.Maybe+import Data.Monoid (Dual, Endo, Monoid(..))+import qualified Data.Vault as Vault++import Data.Hashable+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set++import Reactive.Banana.Internal.AST+import Reactive.Banana.Internal.InputOutput+import Reactive.Banana.Internal.TotalOrder as TotalOrder++import Debug.Trace++type Map = Map.HashMap+type Set = Set.HashSet++{-----------------------------------------------------------------------------+    Representation of the dependency graph+    and associated lenses+------------------------------------------------------------------------------}+-- Dependency graph+data Graph b+    = Graph+    { grFormulas  :: Formulas                -- formulas for calculation+    , grChildren  :: Map SomeNode [SomeNode] -- reverse dependencies+    , grEvalOrder :: EvalOrder               -- evaluation order+    , grOutput    :: Node b                  -- root node+    , grInputs    :: Inputs                  -- input dispatcher+    }+type Formulas  = Vault.Vault            -- mapping from nodes to formulas+type EvalOrder = TotalOrder SomeNode    -- evaluation order+type Values    = Vault.Vault            -- current event values+type Inputs    = Map Channel [SomeNode] -- mapping from input channels to nodes++-- | Turn a 'Vault.Key' into a lens for the vault+vaultLens :: Vault.Key a -> (Vault.Vault :-> Maybe a)+vaultLens key = lens (Vault.lookup key) (adjust)+    where+    adjust Nothing  = Vault.delete key+    adjust (Just x) = Vault.insert key x ++-- | Formula used to calculate the value at a node.+formula :: Node a -> (Graph b :-> Maybe (FormulaD Nodes a))+formula node = vaultLens (keyFormula node) . formulaLens+    where formulaLens = lens grFormulas (\x g -> g { grFormulas = x})++-- | All nodes that directly depend on this one via the formula.+children :: Node a -> (Graph b :-> [SomeNode])+children node = lens (Map.lookupDefault [] (Exists node) . grChildren)+    (error "TODO: can't set children yet")++-- | Current value for a node.+value :: Node a -> (Values :-> Maybe a)+value node = vaultLens (keyValue node)++{-----------------------------------------------------------------------------+    Operations specific to the DSL+------------------------------------------------------------------------------}+-- | Extract the dependencies of a node from its formula.+-- (boilerplate)+dependencies :: ToFormula t => FormulaD t a -> [SomeFormula t]+dependencies = caseFormula goE goB+    where+    goE :: ToFormula t => EventD t a -> [SomeFormula t]+    goE (Never)             = []+    goE (UnionWith f e1 e2) = [ee e1,ee e2]+    goE (FilterE _ e1)      = [ee e1]+    goE (ApplyE  b1 e1)     = [bb b1, ee e1]+    goE (AccumE  _ e1)      = [ee e1]+    goE _                   = []++    goB :: ToFormula t => BehaviorD t a -> [SomeFormula t]+    goB (Stepper x e1)      = [ee e1]+    goB _                   = []++-- | Nodes whose *current* values are needed to calculate+-- the current value of the given node.+-- (boilerplate)+dependenciesEval :: ToFormula t => FormulaD t a -> [SomeFormula t]+dependenciesEval (E (ApplyE b e)) = [ee e]+dependenciesEval formula          = dependencies formula ++-- | Replace expressions by nodes.+-- (boilerplate)+toFormulaNodes :: FormulaD Expr a -> FormulaD Nodes a+toFormulaNodes = caseFormula (E . goE) (B . goB)+    where+    node :: Pair Node f a -> Node a+    node = fstPair+    +    goE :: forall a. EventD Expr a -> EventD Nodes a+    goE (Never)             = Never+    goE (UnionWith f e1 e2) = UnionWith f (node e1) (node e2)+    goE (FilterE p e)       = FilterE p (node e)+    goE (ApplyE  b e)       = ApplyE (node b) (node e)+    goE (AccumE  x e)       = AccumE x (node e)+    goE (InputE x)          = InputE x++    goB :: BehaviorD Expr a -> BehaviorD Nodes a+    goB (Stepper x e)       = Stepper x (node e)+    goB (InputB x)          = InputB x+++-- Evaluation++-- | Evaluate the current value of a given event expression.+calculateE+    :: forall a b.+       (forall e. Node e -> Maybe e)  -- retrieve current event values+    -> (forall b. Node b -> b)        -- retrieve old behavior values+    -> Node a                         -- node ID+    -> EventD Nodes a                 -- formula to evaluate+    -> ( Maybe a                      -- current event value+       , Graph b -> Graph b)          -- (maybe) change formulas in the graph +calculateE valueE valueB node =+    maybe (Nothing,id) (\(x,f) -> (Just x, f)) . goE+    where+    goE :: EventD Nodes a -> Maybe (a, Graph b -> Graph b)+    goE (Never)             = nothing+    goE (UnionWith f e1 e2) = case (valueE e1, valueE e2) of+        (Just e1, Just e2) -> just $ f e1 e2+        (Just e1, Nothing) -> just e1+        (Nothing, Just e2) -> just e2+        (Nothing, Nothing) -> nothing+    goE (FilterE p e)       = valueE e >>=+        \e -> if p e then just e else nothing+    goE (ApplyE  b e)       = (just . (valueB b $)) =<< valueE e+    goE (AccumE  x e)       = case valueE e of+        Nothing -> just x+        Just f  -> let y = f x in+            Just (y, set (formula node) . Just $ E (AccumE y e))+    goE (InputE _)          = -- input values can be retrieved by node+        just =<< valueE node++just x  = Just (x, id)+nothing = Nothing++-- | Evalute the new value of a given behavior expression+calculateB+    :: forall a b.+       (forall e. Node e -> Maybe e) -- retrieve current event values+    -> Node a                        -- node ID+    -> BehaviorD Nodes a             -- formula to evaluate+    -> Graph b -> Graph b            -- (maybe) change formulas in the graph+calculateB valueE node = maybe id id . goB+    where+    goB :: BehaviorD Nodes a -> Maybe (Graph b -> Graph b) +    goB (Stepper x e)     =+        (\y -> set (formula node) $ Just $ B (Stepper y e)) <$> valueE e+    goB (InputB x)        = error "TODO"+++{-----------------------------------------------------------------------------+    Building the dependency graph+------------------------------------------------------------------------------}+-- | Build full graph from an expression.+buildGraph :: Formula Expr b -> Graph b+buildGraph expr = graph+    where+    graph = Graph+        { grFormulas  = grFormulas+        , grChildren  = buildChildren  (Exists root) grFormulas+        , grEvalOrder = buildEvalOrder graph+        , grOutput    = root+        , grInputs    = buildInputs    (Exists root) grFormulas+        }+    grFormulas = buildFormulas (Exists expr)+    root       = fstPair expr++-- | Build a graph of formulas from an expression+buildFormulas :: SomeFormula Expr -> Formulas+buildFormulas expr =+    unfoldGraphDFSWith leftComposition f expr $ Vault.empty+    where+    f (Exists (Pair node formula)) =+        ( \formulas -> Vault.insert (keyFormula node) formula' formulas+        , dependencies formula )+        where+        formula' = toFormulaNodes formula++-- | Build reverse dependencies, starting from one node.+buildChildren :: SomeNode -> Formulas -> Map SomeNode [SomeNode]+buildChildren root formulas =+    unfoldGraphDFSWith leftComposition f root $ Map.empty+    where+    f (Exists node) = (addChild deps, deps)+        where+        addChild      = concatenate . map (\node -> Map.insertWith (++) node [child])+        child         = Exists node :: SomeNode+        Just formula' = getFormula' node formulas+        deps          = dependencies formula'++getFormula' node formulas = Vault.lookup (keyFormula node) formulas++concatenate :: [a -> a] -> (a -> a)+concatenate = foldr (.) id++-- | Start at some node and update the evaluation order of+-- the node and all of its dependencies.+updateEvalOrder :: SomeNode -> Formulas -> EvalOrder -> EvalOrder+updateEvalOrder = error "TODO"++-- | Build evaluation order from scratch+-- = topological sort+buildEvalOrder :: Graph a -> EvalOrder+buildEvalOrder graph =+    -- we have to build an evaluation order for the root node+    -- and for all the dependencies of a behavior+    TotalOrder.fromAscList $+        concatMap (\x -> unfoldGraphDFSWith leftComposition f x [])+                  (root:findBehaviors)+    where+    root = Exists $ grOutput graph+    f (Exists node) = ((Exists node:), dependenciesEval formula')+        where Just formula' = get (formula node) graph+    +    -- find all the behavior nodes in the graph+    findBehaviors :: [SomeNode]+    findBehaviors = traverseNodes g graph+        where+        g :: Node a -> FormulaD Nodes a -> [SomeNode]+        g node (B _) = [Exists node]+        g _    _     = []++-- | Build collection of input nodes from scratch+buildInputs :: SomeNode -> Formulas -> Inputs+buildInputs root formulas =+    unfoldGraphDFSWith leftComposition f root Map.empty+    where+    f (Exists node) = (addInput, dependencies formula')+        where+        Just formula' = getFormula' node formulas+        addInput :: Inputs -> Inputs+        addInput = case formula' of+            E (InputE i) -> Map.insertWith (++) (getChannel i) [Exists node]+            _            -> id++-- | Traverse all nodes of the graph.+-- The order in which this happens is left unspecified.+traverseNodes+    :: Monoid t+    => (forall a. Node a -> FormulaD Nodes a -> t) -- map nodes to monoid values+    -> Graph b+    -> t+traverseNodes f graph =+    unfoldGraphDFSWith reifyMonoid g (Exists $ grOutput graph)+    where+    g (Exists node) = (f node formula', dependencies formula')+        where Just formula' = get (formula node) graph++{-----------------------------------------------------------------------------+    Generic Graph Traversals+------------------------------------------------------------------------------}+-- | Dictionary for defining monoids on the fly.+data MonoidDict t = MonoidDict t (t -> t -> t)++reifyMonoid :: Monoid t => MonoidDict t+reifyMonoid = MonoidDict mempty mappend++-- | Unfold a graph,+-- i.e. unfold a given state  s  into a concatenation of monoid values+-- while ignoring duplicate states.+-- Depth-first order.+unfoldGraphDFSWith+    :: forall s t. (Hashable s, Eq s) => MonoidDict t -> (s -> (t,[s])) -> s -> t+unfoldGraphDFSWith (MonoidDict empty append) f s = go Set.empty [s]+    where+    go :: Set s -> [s] -> t+    go seen []      = empty+    go seen (x:xs)+        | x `Set.member` seen = go seen xs+        | otherwise           = t `append` go (Set.insert x seen) (ys++xs)+        where+        (t,ys) = f x++-- | Monoid of endomorphisms, leftmost function is applied *last*.+leftComposition :: MonoidDict (a -> a)+leftComposition = MonoidDict id (flip (.))++{-+testDFS :: Int -> [Int]+testDFS = unfoldGraphDFSWith (MonoidDict [] (++)) go+    where go n = ([n],if n <= 0 then [] else [n-2,n-1])+-}++{-----------------------------------------------------------------------------+    Reduction and Evaluation+------------------------------------------------------------------------------}+-- type Queue = [SomeNode]++-- | Perform evaluation steps until all values have percolated through the graph.+evaluate :: Queue q => q SomeNode -> Graph b -> Values -> (Maybe b, Graph b)+evaluate startQueue startGraph startValues =+    (get (value (grOutput startGraph)) endValues, endGraph)+    where    +    (_,endValues,endGraph) =+        until (isEmpty . queue) step (startQueue,startValues,startGraph)+    +    queue (q,_,_) = q+    step  (q,v,g) = (q',v',f g)+        where (q',v',f) = evaluationStep startGraph q v++-- | Perform a single evaluation step.+evaluationStep+    :: forall q b. Queue q+    => Graph b                      -- initial graph shape+    -> q SomeNode                   -- queue of nodes to process+    -> Values                       -- current event values+    -> (q SomeNode, Values, Graph b -> Graph b)+evaluationStep graph queue values = case minView queue of+        Just (Exists node, queue) -> go node queue+        Nothing                   -> error "evaluationStep: queue empty"+    where+    go :: forall a b.+        Node a -> q SomeNode -> (q SomeNode, Values, Graph b -> Graph b)+    go node queue =+        let -- lookup functions+            valueE :: forall e. Node e -> Maybe e+            valueE node = get (value node) values+            valueB :: forall b. Node b -> b+            valueB node = case get (formula node) graph of+                Just (B (Stepper b _)) -> b+                _               -> error "evaluationStep: behavior not found"++            err = error "evaluationStep: formula not found"+        in -- evaluation+            case maybe err id $ get (formula node) graph of+            B formulaB ->   -- evalute behavior+                (queue, values, calculateB valueE node formulaB)+            E formulaE ->   -- evaluate event+                let -- calculate current value+                    (maybeval, f) =+                        calculateE valueE valueB node formulaE+                    -- set value if applicable+                    setValue = case maybeval of+                        Just x  -> set (value node) (Just x)+                        Nothing -> id+                    -- evaluate children only if node doesn't return Nothing+                    setQueue = case maybeval of+                        Just _  -> insertList $ get (children node) graph+                        Nothing -> id+                in (setQueue queue, setValue values, f)++{-----------------------------------------------------------------------------+    Convert into an automaton+------------------------------------------------------------------------------}+compileToAutomaton :: Event Expr b -> IO (Automaton b)+compileToAutomaton expr = return $ fromStateful automatonStep $ buildGraph (e expr)+    where+    e :: Event Expr b -> Formula Expr b+    e (Pair n x) = Pair n (E x)+    +-- single step function of the automaton+automatonStep :: [InputValue] -> Graph b -> IO (Maybe b, Graph b)+automatonStep inputs graph = return (b, graph')+    where    +    -- figure out nodes corresponding to input values+    inputNodes :: [(InputValue, SomeNode)]+    inputNodes =+        [ (i, node)+        | i <- inputs+        , nodes <- maybeToList $ Map.lookup (getChannel i) (grInputs graph)+        , node  <- nodes]++    -- fill up values for start/input nodes+    startValues = foldr insertInput Vault.empty inputNodes+    -- insert a single input into the start values+    insertInput :: (InputValue, SomeNode) -> Values -> Values+    insertInput (i,somenode) = maybe id id $+        withInputNode somenode (\node channel ->+            maybe id (Vault.insert (keyValue node)) $ fromValue channel i+            )  ++    -- unpack  InputE  node if applicable+    withInputNode :: SomeNode+        -> (forall a. Node a -> InputChannel a -> b) -> Maybe b+    withInputNode somenode f = case somenode of+        Exists node ->+            let theformula = get (formula node) graph+            in case theformula of+                Just (E (InputE channel)) -> Just $ f node channel+                _ -> Nothing+    +    -- perform evaluation+    (b,graph') = withTotalOrder (grEvalOrder graph) $ \qempty ->+        evaluate (insertList (map snd inputNodes) qempty) graph startValues+++

@@ -0,0 +1,123 @@+{-----------------------------------------------------------------------------+    Reactive Banana+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, BangPatterns #-}+module Reactive.Banana.Internal.TotalOrder (+    -- * Synopsis+    -- | Data structure that represents a total order.+    +    -- * TotalOrder+    TotalOrder, TotalOrderZipper,+    open, close, fromAscList, ascend, descend, insertBeforeFocus, delete,+    withTotalOrder,+    +    -- * Queue+    Queue(..), insertList, isEmpty,+    ) where+++import Control.Applicative+import Control.Arrow (second)++import qualified Data.List+import Data.Maybe+import Data.Ord++import Data.Hashable+import qualified Data.HashMap.Strict as Map+import qualified Data.Set as Set++type Map = Map.HashMap+type Set = Set.Set++{-----------------------------------------------------------------------------+    Total Order implementation+------------------------------------------------------------------------------}+-- Data type representing a total order between elements+-- It's simply an ordered list of elements+newtype TotalOrder a = TO { unTO :: Map a Int }++-- Zipper variant of a total order.+data TotalOrderZipper a = TOZ { down :: [a], up :: [a] }++open  :: TotalOrder a -> TotalOrderZipper a+open (TO order) = TOZ { down = [], up = Map.keys order }++close :: (Hashable a, Eq a) => TotalOrderZipper a -> TotalOrder a+close order = TO $ Map.fromList $ zip (reverse (down order) ++ up order) [1..]++fromAscList :: (Hashable a, Eq a) => [a] -> TotalOrder a+fromAscList xs = close $ TOZ { down = [], up = xs }+++-- move to the next larger element+ascend       :: TotalOrderZipper a -> TotalOrderZipper a+ascend (TOZ xs []    ) = TOZ xs     []+ascend (TOZ xs (y:ys)) = TOZ (y:xs) ys++-- move to the next smaller element+descend      :: TotalOrderZipper a -> TotalOrderZipper a+descend (TOZ []     ys) = TOZ [] ys+descend (TOZ (x:xs) ys) = TOZ xs (x:ys)++-- insert an element before the current one+insertBeforeFocus :: a -> TotalOrderZipper a -> TotalOrderZipper a+insertBeforeFocus x (TOZ xs ys) = TOZ (x:xs) ys++-- delete an element from a total order+delete       :: Eq a => a -> TotalOrderZipper a -> TotalOrderZipper a+delete x (TOZ xs ys) = TOZ (delete' x xs) (delete' x ys)+    where delete' = Data.List.delete++{-----------------------------------------------------------------------------+   Queue based on a total order+------------------------------------------------------------------------------}+-- | Obtain a queue based on a particular total order.+--+-- The type system ensures that the queue is only used temporarily.+-- The argument passed to the function is the empty queue.+withTotalOrder :: TotalOrder a -> (forall q. Queue q => q a -> b) -> b+withTotalOrder order f = f empty+    where empty = Q { order = order, queue = Set.empty }++-- public interface+class Queue q where+    insert  :: (Hashable a, Eq a) => a -> q a -> q a+    minView :: q a -> Maybe (a, q a)+    size    :: q a -> Int++-- | Check whether a queue is empty.+isEmpty :: Queue q => q a -> Bool+isEmpty = isNothing . minView++-- | Insert a collection of elements+insertList :: (Queue q, Hashable a, Eq a) => [a] -> q a -> q a+insertList xs q = foldl (flip insert) q xs++-- concrete implementation+data MyQueue a = Q { order :: TotalOrder a, queue :: Set (Pair Int a) }++data Pair a b = Pair !a b+fstPair (Pair a _) = a+instance Eq a => Eq (Pair a b) where+    x == y = fstPair x == fstPair y+instance Ord a => Ord (Pair a b) where+    compare = comparing fstPair++-- set the queue field+setQueue :: MyQueue a -> Set (Pair Int a) -> MyQueue a+setQueue q b = q { queue = b }++-- find the index of a particular element in a Total Order+position :: (Hashable a, Eq a) => TotalOrder a -> a -> Int+position (TO order) x = pos+    where Just pos = Map.lookup x order++instance Queue MyQueue where+    insert x q = q { queue = Set.insert (Pair pos x) (queue q) }+        where pos = position (order q) x+    minView  q = f <$> Set.minView (queue q)+        where f (Pair _ a,set) = (a, setQueue q set)+    size     q = Set.size (queue q)++

@@ -1,290 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-    -    Class interface + Semantic model-------------------------------------------------------------------------------}-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, EmptyDataDecls,-  MultiParamTypeClasses #-}-module Reactive.Banana.Model (-    -- * Synopsis-    -- | Combinators for building event networks and their semantics.-    -    -- * Core Combinators-    module Control.Applicative,-    FRP(..),-    Event, Behavior,-    -- $classes-    -    -- * Derived Combinators-    whenE, filterJust, mapAccum, Apply(..),-    -    -- * Model implementation-    Model,-    Time, interpretTime, interpret,-    ) where--import Control.Applicative-import qualified Data.List-import Data.Maybe-import Prelude hiding (filter)-import Data.Monoid--{------------------------------------------------------------------------------    Class interface-------------------------------------------------------------------------------}-data family Event f    :: * -> *-data family Behavior f :: * -> *--{- | The 'FRP' class defines the primitive API for functional reactive programming.-Each instance 'f' defines two type constructors @Event f@ and @Behavior f@-and corresponding combinators.--@Event f a@ represents a stream of events as they occur in time.-Semantically, you can think of @Event f a@ as an infinite list of values-that are tagged with their corresponding time of occurence,--> type Event f a = [(Time,a)]--@Behavior f a@ represents a value that varies in time. Think of it as--> type Behavior f a = Time -> a--While these type synonyms 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 model implementation,-called 'Model'.-This model is /authoritative/: every instance of the 'FRP' class /must/-give the same results as the model when observed with the 'interpret' function.-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.--Minimal complete definition of the 'FRP' class: One of 'filter' or 'filterApply'-and one of 'accumB' or 'stepper'.---}--class (Functor (Event f),-       Functor (Behavior f), Applicative (Behavior f)) => FRP f where-    -    -- | Event that never occurs.-    -- Think of it as @never = []@.-    never    :: Event f a-    -    -- | 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 f a -> Event f a -> Event f a-    -    -- | 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 f (a -> b) -> Event f a -> Event f b---    -- | 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 f a -> Event f a-    -    -- | Allow all events that fulfill the time-varying predicate, discard the rest.-    -- It's a slight generalization of 'filterE'.-    filterApply :: Behavior f (a -> Bool) -> Event f a -> Event f a-    -    -    -- Accumulation.-    -- Note: all accumulation functions are strict in the accumulated value!-    -- acc -> (x,acc) is the order used by  unfoldr  and  State--    -- | 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 f a -> Behavior f a--    -- | 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 f (a -> a) -> Behavior f a-    -    -- | 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 f (a -> a) -> Event f a-    -    -    -- implementation filter-    filterE p = filterApply (pure p)-    filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp)    -    -    -- implementation accumulation-    accumB  acc = stepper acc . accumE acc-    stepper acc = accumB acc . fmap const--{-$classes--/Further combinators that Haddock can't document properly./--> instance FRP f => Monoid (Event f a)--The combinators 'never' and 'union' turn 'Event' into a monoid.--> instance FPR f => Applicative (Behavior f)--'Behavior' is an applicative functor. In particular, we have the following functions.--> pure :: FRP f => a -> Behavior f a--The constant time-varying value. Think of it as @pure x = \\time -> x@.--> (<*>) :: FRP f => Behavior f (a -> b) -> Behavior f a -> Behavior f b--Combine behaviors in applicative style.-Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@.---}--instance FRP f => Monoid (Event f a) where-    mempty  = never-    mappend = union--{------------------------------------------------------------------------------    Derived Combinators-------------------------------------------------------------------------------}--- | Variant of 'filterApply'.-whenE :: FRP f => Behavior f Bool -> Event f a -> Event f a-whenE bf = filterApply (const <$> bf)---- | Variant of 'filterE'. Keep only the 'Just' values.-filterJust :: FRP f => Event f (Maybe a) -> Event f a-filterJust = fmap (maybe err id) . filterE isJust-    where err = error "Reactive.Banana.Model.filterJust: Internal error. :("---- | Efficient combination of 'accumE' and 'accumB'.-mapAccum :: FRP f => acc -> Event f (acc -> (x,acc)) -> (Event f x, Behavior f 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 FRP f => Apply (Behavior f) (Event f) where-    (<@>) = apply--{------------------------------------------------------------------------------    Semantic model-------------------------------------------------------------------------------}--- | The type index 'Model' represents the model implementation.--- You are encouraged to look at the source code!--- (If there is no link to the source code at every type signature,--- then you have to run @cabal@ with @--hyperlink-source@ flag.)-data Model---- Stream of events. Simultaneous events are grouped into lists.-newtype instance Event Model a = E { unE :: [[a]] }--- Stream of values that the behavior takes.-newtype instance Behavior Model a = B { unB :: [a] }---instance Functor (Event Model) where-    fmap f = E . map (map f) . unE--instance Applicative (Behavior Model) where-    pure x    = B $ repeat x-    bf <*> bx = B $ zipWith ($) (unB bf) (unB bx)--instance Functor (Behavior Model) where-    fmap = liftA--instance FRP Model where-    never       = E $ repeat []-    union e1 e2 = E $ zipWith (++) (unE e1) (unE e2)-    -    filterApply bp = E . zipWith (\p xs-> Data.List.filter p xs) (unB bp) . unE-    apply b    = E . zipWith (\f xs -> map f xs) (unB b) . unE--    stepper x  = B . scanl go x . unE-        where go x e = last (x:e)--    accumE acc = E . accumE' acc . unE-        where-        accumE' acc []     = []-        accumE' acc (e:es) = e' : accumE' acc' es-            where-            vals = scanl' (flip ($)) acc e-            e'   = tail $ vals-            acc' = last vals---- 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---- | Slightly simpler interpreter that does not mention 'Time'.--- Returns lists of event values that occur simultaneously.-interpret :: (Event Model a -> Event Model b) -> [a] -> [[b]]-interpret f = unE . f . E . map (:[])--type Time = Double--- | Interpreter that corresponds to your mental model.-interpretTime :: (Event Model a -> Event Model b) -> [(Time,a)] -> [(Time,b)]-interpretTime f xs =-    concat . zipWith tag times . interpret f . map snd $ xs-    where-    times = map fst xs-    tag t xs = map (\x -> (t,x)) xs--{------------------------------------------------------------------------------    Example: Counter that can be decreased-------------------------------------------------------------------------------}-example :: FRP f => Event f () -> Event f Int-example edec = apply ((\c _ -> c) <$> bcounter) ecandecrease-    where-    bcounter     = accumB 10 $ (subtract 1) <$ ecandecrease-    ecandecrease = whenE ((>0) <$> bcounter) edec--testModel = interpret example $ replicate 15 ()--- > testModel--- [[10],[9],[8],[7],[6],[5],[4],[3],[2],[1],[],[],[],[],[]]--example2 :: FRP f => Event f () -> Event f Int-example2 e = apply (const <$> b) e-    where-    b = accumB 0 ((+1) <$ e)-

@@ -1,430 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-    -    A push-driven implementation-------------------------------------------------------------------------------}-{-# LANGUAGE TypeFamilies, FlexibleInstances, EmptyDataDecls, GADTs,-     TupleSections, BangPatterns #-}-module Reactive.Banana.PushIO where--import Reactive.Banana.Model hiding (Event, Behavior, interpret)-import qualified Reactive.Banana.Model as Model--import Data.Vault (Vault)-import qualified Data.Vault as Vault---import Control.Applicative-import Control.Arrow (second)-import Control.Monad-import Control.Monad.IO.Class       (liftIO)-import Control.Monad.Trans.Class    (lift)-import Control.Monad.Trans.Identity-import Control.Monad.Trans.State-import Control.Monad.Trans.Writer-import Data.Maybe-import Data.Monoid-import System.IO.Unsafe--import System.IO--- debug s = hPutStrLn stderr s--{------------------------------------------------------------------------------    Observable sharing-    -    References can be used in the  Store  monad.-    This mimicks the case where unique IDs are used-    to look up a value in the environment.-    In this case, the environment is passed around by the  Store  monad.-------------------------------------------------------------------------------}--- store monad-type Store = StateT Vault IO--- references to observe sharing-type Ref a = Vault.Key a--runStore :: Store a -> IO a-runStore m = evalStateT m Vault.empty---- create a new reference.-newRef   :: IO (Ref a)--- read a reference. Only possible in the  Store  monad.-readRef  :: Ref a -> Store (Maybe a)-writeRef :: Ref a -> a -> Store ()--newRef         = Vault.newKey-readRef ref    = Vault.lookup ref <$> get-writeRef ref x = modify $ Vault.insert ref x---- invalid reference that may not store values-invalidRef = error "Store: invalidRef. This is an internal bug."--{------------------------------------------------------------------------------    Cache, generalities-------------------------------------------------------------------------------}--- A cache stores values of different types--- and finalizers to change them.-data Cache = Cache {-              vault :: Vault-            , initializers :: [VaultChanger]-            , finalizers   :: [VaultChanger] }-type VaultChanger = Run ()--emptyCache :: Cache-emptyCache = Cache Vault.empty [] []---- monad to build the network in-type Compile = StateT Cache Store--- monad to run the network in-type Run     = StateT Vault IO--runCompile :: Compile a -> Store (a, Cache)-runCompile m = runStateT m $ Cache { vault = Vault.empty, initializers = [], finalizers = [] }--registerInitializer, registerFinalizer :: VaultChanger -> Compile ()-registerFinalizer m   = modify $-    \cache -> cache { finalizers   = finalizers cache ++ [m] }-registerInitializer m = modify $-    \cache -> cache { initializers = initializers cache ++ [m] }--runRun :: Run a -> Cache -> IO (a, Cache)-runRun m cache = do-        let vault1 = vault cache-        -- run the initializers-        vault2     <- runVaultChangers (initializers cache) vault1-        -- run the action-        (x,vault3) <- runStateT m vault2-        -- run all the finalizers              -        vault4     <- runVaultChangers (finalizers cache) vault3-        -- return new cache-        return (x,cache{ vault = vault4 })-    where-    runVaultChangers = execStateT . sequence_---- helper functions for reading and writing keys into the vault cache-writeVaultKey ref x = do-    vault  <- get-    let vault' = Vault.insert ref x vault-    put $ vault'-readVaultKey ref = Vault.lookup ref <$> get--{------------------------------------------------------------------------------    Cache, particular reference types-------------------------------------------------------------------------------}--- CacheRef--- A simple value to be cached. Lasts one phase. Useful for sharing.-type CacheRef a = Vault.Key a--newCacheRef   :: Compile (CacheRef a)-readCacheRef  :: CacheRef a -> Run (Maybe a)-writeCacheRef :: CacheRef a -> a -> Run ()--newCacheRef      = do-    key <- liftIO $ Vault.newKey-    registerFinalizer $ put . Vault.delete key =<< get-    return key-readCacheRef  = readVaultKey-writeCacheRef = writeVaultKey---- Accumulation values.--- Cache and accumulate a value over several phases.-type AccumRef a = Vault.Key a--newAccumRef    :: a -> Compile (AccumRef a)-readAccumRef   :: AccumRef a -> Run a-updateAccumRef :: AccumRef a -> (a -> a) -> Run a -- strict!--newAccumRef x     = do-    ref    <- liftIO $ Vault.newKey-    vault2 <- Vault.insert ref x . vault <$> get-    modify $ \cache -> cache { vault = vault2 }-    return ref-readAccumRef ref  =-    fromJustError "Reactive.Banana.PushIO.readAccumRef: internal error"-    <$> readVaultKey ref-updateAccumRef ref f = do-    Just x <- readVaultKey ref -    let !y = f x-    writeVaultKey ref y-    return y--fromJustError e = maybe (error e) id---- BehaviorRef.--- Cache and accumulate a value over several phases,--- but updates are only visible at the beginning of a new phase.--- (accumulator, temporary reference for each phase)-type BehaviorRef a = (AccumRef a, CacheRef a)--newBehaviorRefPoll   :: IO a -> Compile (BehaviorRef a)-newBehaviorRefAccum  :: a -> Compile (BehaviorRef a)-readBehaviorRef      :: BehaviorRef a -> Run a-updateBehaviorRef    :: BehaviorRef a -> (a -> a) -> Run () -- strict!--newBehaviorRef m = do-    temp <- newCacheRef-    registerInitializer $ writeCacheRef temp =<< m-    return (undefined, temp)-newBehaviorRefPoll    = newBehaviorRef . liftIO-newBehaviorRefAccum x = do-    acc  <- newAccumRef x-    (_,temp) <- newBehaviorRef $ readAccumRef acc-    return (acc, temp)-readBehaviorRef   (_, temp)   =-    fromJustError "Reactive.Banana.PushIO.readBehaviorRef: internal error"-    <$> readCacheRef temp-updateBehaviorRef (acc, temp) = void . updateAccumRef acc---{------------------------------------------------------------------------------    Abstract syntax tree-------------------------------------------------------------------------------}-data Accum-data Shared-data Linear--type EventStore a = [(Channel, CacheRef a)]--type family   Event t a-type instance Event Accum  a = (Ref (EventStore a), EventD Accum a)-type instance Event Shared a = (Ref (EventStore a), EventD Shared a)-type instance Event Linear a = EventD Linear a--data EventD t :: * -> * where-    Filter    :: (a -> Bool) -> Event t a -> EventD t a-    ApplyE    :: Behavior t (a -> b) -> Event t a -> EventD t b-    AccumE    :: a -> Event t (a -> a) -> EventD t a-    Union     :: Event t a -> Event t a -> EventD t a-    Never     :: EventD t a-    -    -- internal combinators-    Input         :: Channel -> Key a -> EventD t a-    Reactimate    :: Event t (IO ()) -> EventD t ()-    -    ReadCache     :: Channel -> CacheRef a -> EventD t a-    WriteCache    :: CacheRef a -> Event t a -> EventD t a-    -    UpdateAccum    :: AccumRef a    -> Event t (a -> a) -> EventD t a-    UpdateBehavior :: BehaviorRef a -> Event t (a -> a) -> EventD t ()---type BehaviorStore a = BehaviorRef a--type family   Behavior t a-type instance Behavior Accum  a = (Ref (BehaviorStore a), BehaviorD Accum  a)-type instance Behavior Shared a = (Ref (BehaviorStore a), BehaviorD Linear a)-type instance Behavior Linear a = (Ref (BehaviorStore a), BehaviorD Linear a)--data BehaviorD t a where-    Pure         :: a -> BehaviorD t a-    ApplyB       :: Behavior t (a -> b) -> Behavior t a -> BehaviorD t b-    AccumB       :: a -> Event t (a -> a) -> BehaviorD t a-    Poll         :: IO a -> BehaviorD t a-    -    -- internal combinators-    ReadBehavior :: BehaviorRef a -> BehaviorD t a--{------------------------------------------------------------------------------    Storing heterogenous input values-------------------------------------------------------------------------------}-type Channel  = Integer     -- identifies an input-type Key      = Vault.Key -type Universe = Vault.Vault--newUniverseKey :: IO (Key a)-newUniverseKey = Vault.newKey--fromUniverse :: Key a -> Universe -> Maybe a-fromUniverse = Vault.lookup--toUniverse :: Key a -> a -> Universe-toUniverse k a = Vault.insert k a Vault.empty--{------------------------------------------------------------------------------    Compilation-------------------------------------------------------------------------------}--- allocated caches for acummulated and external behaviors,--- turn them into reads from the cache-type CompileReadBehavior = WriterT [Event Shared ()] Compile--compileReadBehavior :: Event Accum () -> Compile (Event Shared ())-compileReadBehavior e1 = do-        (e,es) <- runWriterT (goE e1)-        -- include updates to Behavior as additional events-        let union e1 e2 = (invalidRef, Union e1 e2)-        return $ foldr1 union (e:es)-    where    -    -- boilerplate traversal for events-    goE :: Event Accum a -> CompileReadBehavior (Event Shared a)-    goE (ref, Filter p e )      = (ref,) <$> (Filter p   <$> goE e)-    goE (ref, Union e1 e2)      = (ref,) <$> (Union      <$> goE e1 <*> goE e2)-    goE (ref, ApplyE b e )      = (ref,) <$> (ApplyE     <$> goB b  <*> goE e )-    goE (ref, AccumE x e )      = (ref,) <$> (AccumE x   <$> goE e)-    goE (ref, Reactimate e)     = (ref,) <$> (Reactimate <$> goE e)-    goE (ref, Never)            = (ref,) <$> (pure Never)-    goE (ref, Input c k)        = (ref,) <$> (pure $ Input c k)--    -- almost boilerplate traversal for behaviors-    goB :: Behavior Accum a -> CompileReadBehavior (Behavior Shared a)-    goB (ref, Pure x      ) = (ref,) <$> (Pure   <$> return x)-    goB (ref, ApplyB bf bx) = (ref,) <$> (ApplyB <$> goB bf <*> goB bx)-    goB (ref, Poll io     ) = (ref,) <$> (ReadBehavior <$> makeRef)-        where-        makeRef = do-            m <- lift . lift $ readRef ref-            case m of-                Just r  -> return r-                Nothing -> do-                    r <- lift $ newBehaviorRefPoll io-                    lift . lift $ writeRef ref r-                    return r-    goB (ref, AccumB x e  ) = (ref,) <$> (ReadBehavior <$> makeRef)-        where-        makeRef = do-            m <- lift . lift $ readRef ref-            case m of-                Just r  -> return r-                Nothing -> do-                    -- create new BehaviorRef and share it-                    r <- lift $ newBehaviorRefAccum x-                    lift . lift $ writeRef ref r--                    -- remove  accumB  from the other events-                    e <- goE e-                    tell [(invalidRef, UpdateBehavior r e)]-                    return r---- fan out unions into linear paths-type EventLinear a = (Channel, Event Linear a)--compileUnion :: Event Shared a -> Compile [Event Linear a]-compileUnion e = map snd <$> goE e-    where-    goE :: Event Shared a -> Compile [EventLinear a]-    goE (ref, Filter p e )        = cacheEvents ref (map2 (Filter p) <$> goE e)-    goE (ref, ApplyE b e )        = cacheEvents ref (map2 (ApplyE b) <$> goE e)-    goE (ref, AccumE x e )        = cacheEvents ref (compileAccumE x =<< goE e)-    goE (_  , UpdateBehavior b e) = map2 (UpdateBehavior b) <$> goE e-    goE (_  , Reactimate e)       = map2 (Reactimate)      <$> goE e-    goE (_  , Union e1 e2)        = (++) <$> goE e1 <*> goE e2-    goE (_  , Never      )        = return []-    goE (_  , Input channel key)  = return [(channel, Input channel key)]-    -    compileAccumE :: a -> [EventLinear (a -> a)] -> Compile [EventLinear a]-    compileAccumE x es = do-        ref <- newAccumRef x-        return $ map2 (UpdateAccum ref) es-    -    cacheEvents :: Ref (EventStore a)-                -> Compile [EventLinear a] -> Compile [EventLinear a]-    cacheEvents ref mes = do-        m <- lift $ readRef ref-        case m of-            Just cached -> do-                return $ map (\(c,r) -> (c, ReadCache c r)) cached-            Nothing     -> do-                -- compile input events-                es     <- mes-                -- allocate corresponding cache references and share them-                cached <- forM es $ \(c,_) -> do r <- newCacheRef; return (c,r)-                lift $ writeRef ref cached-                -- return events that also write to the cache-                return $ zipWith (second . (WriteCache . snd)) cached es--map2 = map . second---- compile a behavior--- FIXME: take care of sharing, caching-compileBehaviorEvaluation :: Behavior Linear a -> Run a-compileBehaviorEvaluation = goB-    where-    goB :: Behavior Linear a -> Run a-    goB (ref, Pure x)            = return x-    goB (ref, ApplyB bf bx)      = goB bf <*> goB bx-    goB (ref, ReadBehavior refb) = readBehaviorRef refb----- compile path into an IO action-type Path = (Channel, Universe -> Run (IO ()))--- (input_channel, \input_value ->---      do change event_graph_state; return (reactimates_to_be_run) )--compilePath :: Event Linear () -> Path-compilePath e = goE e (const $ return nop)-    where-    goE :: Event Linear a -> (a -> Run (IO ())) -> Path-    goE (Filter p e)         k = goE e $ \x -> if p x then k x else return nop-    goE (ApplyE b e)         k = goE e $ \x -> goB b >>= \f -> k (f x)-    goE (UpdateAccum    r e) k = goE e $ \f -> updateAccumRef r f >>= k-    goE (UpdateBehavior r e) _ = goE e $ \x -> do updateBehaviorRef r x; return nop-        -- note: no  k  here because writing behaviors is the end of a path-    goE (Reactimate e)       _ = goE e $ \x -> return x-    goE (ReadCache c ref)    k =-            (c, \_ -> readCacheRef ref >>= maybe (return nop) k)-    goE (WriteCache ref e)   k = goE e $ \x -> writeCacheRef ref x >> k x-    goE (Input channel key)  k =-            (channel, maybe (error "wrong channel") k . fromUniverse key)-    -    nop = return () :: IO ()-    -    goB :: Behavior Linear a -> Run a-    goB = compileBehaviorEvaluation---- compilation function-compile :: Event Accum () -> IO ([Path], Cache)-compile e = runStore $ runCompile $-    return . map compilePath =<< compileUnion =<< compileReadBehavior e---- debug :: MonadIO m => String -> m ()--- debug = liftIO . putStrLn--{------------------------------------------------------------------------------    Class instances-------------------------------------------------------------------------------}--- | The type index 'PushIO' represents the efficient push-driven implementation--- described here.--- It implements the same 'FRP' interface as the model implementation--- represented by 'Model'.-data PushIO---- type Behavior = Model.Behavior PushIO-newtype instance Model.Behavior PushIO a = Behavior (Behavior Accum a)---- type Event = Model.Event PushIO-newtype instance Model.Event PushIO a = Event (Event Accum a)--unEvent (Event e) = e---- sharing-behavior :: BehaviorD Accum a -> Model.Behavior PushIO a-behavior b = Behavior pair-    where-    {-# NOINLINE pair #-}-    -- mention argument to prevent let-floating  -    pair = unsafePerformIO (fmap (,b) newRef)--event :: EventD Accum a -> Model.Event PushIO a-event e = Event pair-    where-    {-# NOINLINE pair #-}-    -- mention argument to prevent let-floating-    pair = unsafePerformIO (fmap (,e) newRef)---- boilerplate class instances-instance Functor (Model.Event PushIO) where-    fmap f e = apply (pure f) e-    -instance Applicative (Model.Behavior PushIO) where-    pure x = behavior $ Pure x-    (Behavior bf) <*> (Behavior bx) = behavior $ ApplyB bf bx--instance Functor (Model.Behavior PushIO) where-    fmap = liftA--instance FRP PushIO where-    never = event $ Never-    union (Event e1) (Event e2) = event $ Union e1 e2-    filterE p (Event e) = event $ Filter p e-    apply (Behavior bf) (Event ex) = event $ ApplyE bf ex-    accumB x (Event e) = behavior $ AccumB x e-    accumE x (Event e) = event $ AccumE x e-

@@ -4,31 +4,34 @@     Test cases and examples ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, NoMonomorphismRestriction #-}+ module Reactive.Banana.Tests where  import Control.Monad (when) -import Reactive.Banana.Model as Model-import Reactive.Banana.Implementation as Impl+import Reactive.Banana.Combinators -import Test.QuickCheck+-- import Test.QuickCheck+-- import Test.QuickCheck.Property  {-----------------------------------------------------------------------------     Testing ------------------------------------------------------------------------------}-matchesModel :: (Typeable a, Show b, Eq b) =>-    (forall f. FRP f => Event f a -> Event f b) -> [a] -> IO Bool-matchesModel f = \xs -> do-        let bs1 = Model.interpret f xs-        bs2 <- Impl.interpret f xs-        when (bs1 /= bs2) $ print bs1 >> print bs2-        return $ bs1 == bs2-+matchesModel :: (Show b, Eq b)+             => (forall t. Event t a -> Event t b) -> [[a]] -> IO Bool+matchesModel f xs = do+    bs1 <- interpretModel     f xs+    bs2 <- interpretPushGraph f xs+    when (bs1 /= bs2) $ print bs1 >> print bs2+    return $ bs1 == bs2  testSuite = do         -- trivial unit tests-        test add1-        test filtering+        test id+        -- test never1+        test fmap1+        test filter1+        test filter2         test counter         test double         test sharing@@ -38,18 +41,24 @@         --  * algebraic laws         --  * larger examples         --  * quickcheck-    where-    test :: (Show b, Eq b) => (forall f. FRP f => Event f Int -> Event f b)-         -> IO ()-    test f = print =<< matchesModel f [1..8::Int] +test :: (Show b, Eq b) => (forall t. Event t Int -> Event t b) -> IO ()+test f = print =<< matchesModel f (singletons [1..8::Int])++singletons = map (\x -> [x])+ {-----------------------------------------------------------------------------     Examples ------------------------------------------------------------------------------}-test f = Impl.interpret f [1..8::Int]+testModel, testPush :: (forall t. Event t Int -> Event t b) -> IO [[b]]+testModel f = interpretModel     f $ singletons [1..8::Int]+testPush  f = interpretPushGraph f $ singletons [1..8::Int] -add1      = fmap (+1)-filtering = filterE (>= 3) . fmap (subtract 1)+never1 :: Event t Int -> Event t Int+never1    = const never+fmap1     = fmap (+1)+filter1   = filterE (>= 3)+filter2   = filterE (>= 3) . fmap (subtract 1) counter e = apply (pure const <*> bcounter) e     where bcounter = accumB 0 $ fmap (\_ -> (+1)) e double e  = union e e@@ -59,14 +68,14 @@ type Dummy = Int  -- counter that can be decreased as long as it's >= 0-decrease :: FRP f => Event f Dummy -> Event f Int+decrease :: Event t Dummy -> Event t Int decrease edec = apply (const <$> bcounter) ecandecrease     where     bcounter     = accumB 4 $ (subtract 1) <$ ecandecrease     ecandecrease = whenE ((>0) <$> bcounter) edec --- test accumE vs accumE-accumBvsE :: FRP f => Event f Dummy -> Event f Int+-- test accumE vs accumB+accumBvsE :: Event t Dummy -> Event t Int accumBvsE input = e1 `union` e2     where     e  = input `union` input