reactive-banana 0.6.0.0 → 0.7.0.0

raw patch · 25 files changed

+1680/−1354 lines, 25 filesdep +HUnitdep +reactive-bananadep +test-frameworkdep ~QuickCheckdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, reactive-banana, test-framework, test-framework-hunit

Dependency ranges changed: QuickCheck, containers

API changes (from Hackage documentation)

Files

• doc/examples/ActuatePause.hs +1/−0
• doc/examples/SlotMachine.hs +4/−2
• reactive-banana.cabal +29/−18
• src/Reactive/Banana.hs +4/−1
• src/Reactive/Banana/Combinators.hs +20/−69
• src/Reactive/Banana/Experimental/Calm.hs +5/−11
• src/Reactive/Banana/Frameworks.hs +145/−259
• src/Reactive/Banana/Frameworks/AddHandler.hs +55/−0
• src/Reactive/Banana/Internal/AST.hs +0/−215
• src/Reactive/Banana/Internal/Cached.hs +72/−0
• src/Reactive/Banana/Internal/CompileModel.hs +0/−62
• src/Reactive/Banana/Internal/DependencyGraph.hs +81/−0
• src/Reactive/Banana/Internal/EventBehavior1.hs +172/−0
• src/Reactive/Banana/Internal/InputOutput.hs +5/−5
• src/Reactive/Banana/Internal/InterpretModel.hs +0/−75
• src/Reactive/Banana/Internal/Phantom.hs +23/−0
• src/Reactive/Banana/Internal/PulseLatch0.hs +568/−0
• src/Reactive/Banana/Internal/PushGraph.hs +0/−410
• src/Reactive/Banana/Internal/TotalOrder.hs +0/−123
• src/Reactive/Banana/Internal/Types2.hs +59/−0
• src/Reactive/Banana/Model.hs +73/−16
• src/Reactive/Banana/Switch.hs +94/−0
• src/Reactive/Banana/Test.hs +168/−0
• src/Reactive/Banana/Test/Plumbing.hs +102/−0
• src/Reactive/Banana/Tests.hs +0/−88

@@ -12,6 +12,7 @@ import Data.IORef  import Reactive.Banana+import Reactive.Banana.Frameworks   main :: IO ()

@@ -14,6 +14,7 @@ import Data.IORef  import Reactive.Banana as R+import Reactive.Banana.Frameworks as R   main :: IO ()@@ -84,10 +85,11 @@   -- Set up the program logic in terms of events and behaviors.-setupNetwork :: forall t. (EventSource (), EventSource ()) -> NetworkDescription t ()+setupNetwork :: forall t. Frameworks t => +    (EventSource (), EventSource ()) -> Moment t () setupNetwork (escoin,esplay) = do     -- initial random number generator-    initialStdGen <- liftIO $ newStdGen+    initialStdGen <- liftIONow $ newStdGen      -- Obtain events corresponding to the  coin  and  play  commands     ecoin <- fromAddHandler (addHandler escoin)

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.6.0.0+Version:             0.7.0.0 Synopsis:            Practical library for functional reactive programming (FRP). Description:              Reactive-banana is a practical library for Functional Reactive Programming (FRP).@@ -13,6 +13,8 @@     No semantic bugs expected.     Significant API changes are likely in future versions,     though the main interface is beginning to stabilize.+    The @Reactive.Banana.Switch@ module is quite experimental.+    There is currently /no/ garbage collection for dynamically created events.  Homepage:            http://haskell.org/haskellwiki/Reactive-banana License:             BSD3@@ -21,10 +23,12 @@ Maintainer:          Heinrich Apfelmus <apfelmus quantentunnel de> Stability:           Experimental Category:            FRP-Cabal-version:       >=1.6+Cabal-version:       >= 1.9.2 Build-type:          Simple -extra-source-files:  doc/examples/*.hs+extra-source-files:     doc/examples/*.hs,+                        src/Reactive/Banana/Test.hs+                        src/Reactive/Banana/Test/Plumbing.hs  Source-repository head     type:               git@@ -44,7 +48,7 @@     extensions:         CPP,                         Rank2Types, NoMonomorphismRestriction, FlexibleInstances     -    build-depends:      base >= 4.2 && < 5, containers >= 0.3 && < 0.6,+    build-depends:      base >= 4.2 && < 5, containers >= 0.3 && < 0.5,                         transformers >= 0.2 && < 0.4,                         vault == 0.2.*     @@ -52,7 +56,7 @@         extensions:     TypeFamilies, GADTs, MultiParamTypeClasses,                         BangPatterns, TupleSections,                         EmptyDataDecls-        build-depends:  QuickCheck >= 1.2 && < 2.5,+        build-depends:  QuickCheck >= 1.2 && < 2.6,                         fclabels == 1.1.*,                         unordered-containers >= 0.2.1.0 && < 0.3,                         hashable == 1.1.*@@ -63,22 +67,29 @@                         Reactive.Banana.Combinators,                         Reactive.Banana.Experimental.Calm,                         Reactive.Banana.Frameworks,+                        Reactive.Banana.Frameworks.AddHandler,                         Reactive.Banana.Model+                        Reactive.Banana.Switch          other-modules:-                        Reactive.Banana.Internal.InputOutput,-                        Reactive.Banana.Tests-    -    if flag(UseExtensions)-        other-modules:-                        Reactive.Banana.Internal.AST,-                        Reactive.Banana.Internal.InterpretModel,-                        Reactive.Banana.Internal.PushGraph,-                        Reactive.Banana.Internal.TotalOrder-    else-        other-modules:-                        Reactive.Banana.Internal.CompileModel+                        Reactive.Banana.Internal.Cached,+                        Reactive.Banana.Internal.DependencyGraph,+                        Reactive.Banana.Internal.EventBehavior1,+                        Reactive.Banana.Internal.InputOutput+                        Reactive.Banana.Internal.Phantom,+                        Reactive.Banana.Internal.PulseLatch0,+                        Reactive.Banana.Internal.Types2 -                        ++-- compiling the test suite from cabal currently doesn't work+Test-Suite tests+    type:               exitcode-stdio-1.0+    hs-source-dirs:     src+    main-is:            Reactive/Banana/Test.hs+    build-depends:      base >= 4.2 && < 5,+                        HUnit >= 1.2 && < 2,+                        test-framework == 0.6.*,+                        test-framework-hunit == 0.2.*,+                        reactive-banana  

@@ -6,8 +6,11 @@  module Reactive.Banana (     module Reactive.Banana.Combinators,-    module Reactive.Banana.Frameworks,+    module Reactive.Banana.Switch,+    compile,     ) where  import Reactive.Banana.Combinators import Reactive.Banana.Frameworks+import Reactive.Banana.Internal.Types2+import Reactive.Banana.Switch

@@ -12,9 +12,9 @@          -- * Introduction     -- $intro1-    Event(..), Behavior(..),+    Event, Behavior,     -- $intro2-    interpretModel, interpretPushGraph,+    interpret,          -- * Core Combinators     module Control.Applicative,@@ -33,39 +33,17 @@     calm, unionWith,     -- ** Apply class     Apply(..),-    -    -- * Internal-    PrimEvent, PrimBehavior,     ) where  import Control.Applicative import Control.Monad -import Data.Maybe (isJust)+import Data.Maybe (isJust, catMaybes) import Data.Monoid (Monoid(..)) --- The efficient push-based implementation makes essential--- use of several language extensions. To enable building--- if other compilers, we can select the model implementation instead.-#if UseExtensions -import Reactive.Banana.Internal.InputOutput-import Reactive.Banana.Internal.PushGraph-import qualified Reactive.Banana.Internal.AST as Prim-import qualified Reactive.Banana.Internal.InterpretModel as Prim--type PrimEvent     = Prim.Event Prim.Expr-type PrimBehavior  = Prim.Behavior Prim.Expr--#else--import qualified Reactive.Banana.Model as Prim--type PrimEvent    a = Prim.Event a-type PrimBehavior a = Prim.Behavior a--#endif-+import qualified Reactive.Banana.Internal.EventBehavior1 as Prim+import Reactive.Banana.Internal.Types2    {-----------------------------------------------------------------------------@@ -78,21 +56,8 @@  -} -{-| @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 :: PrimEvent [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 :: PrimBehavior a }-    -- ^ (Constructor exported for internal use only.)+-- Event+-- Behavior  {-$intro2 @@ -112,28 +77,13 @@ {-----------------------------------------------------------------------------     Interpetation ------------------------------------------------------------------------------}--- | Interpret with model implementation.+-- | Interpret an event processing function. -- Useful for testing.-interpretModel :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]-interpretModel f xs = map toList <$> Prim.interpretModel (unE . f . E) (map Just xs)+interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]+interpret f xs =+    map toList <$> Prim.interpret (return . unE . f . E) (map Just xs) --- | Interpret with push-based implementation (if available for your compiler).--- Useful for testing.-interpretPushGraph :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] -#if UseExtensions--interpretPushGraph f xs = do-    i <- newInputChannel-    automaton <- compileToAutomaton (unE . f . E $ Prim.inputE i)-    map toList <$> unfoldAutomaton automaton i xs--#else--interpretPushGraph = interpretModel--#endif- toList :: Maybe [a] -> [a] toList Nothing   = [] toList (Just xs) = xs@@ -165,12 +115,19 @@ unions :: [Event t a] -> Event t a unions = foldr union never +-- | Allow all event occurrences that are 'Just' values, discard the rest.+-- Variant of 'filterE'.+filterJust :: Event t (Maybe a) -> Event t a+filterJust = E . Prim.filterJust . Prim.mapE (decide . catMaybes) . unE+    where+    decide xs = if null xs then Nothing else Just xs+ -- | Allow all events that fulfill the predicate, discard the rest. -- Think of it as --  -- > filterE p es = [(time,a) | (time,a) <- es, p a] filterE   :: (a -> Bool) -> Event t a -> Event t a-filterE p = E . Prim.filterE (not . null) . (Prim.mapE (filter p)) . unE+filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing)  -- | Collect simultaneous event occurences. -- The result will never contain an empty list.@@ -218,7 +175,7 @@     concatenate fs acc = (tail values, last values)         where values = scanl' (flip ($)) acc fs -    mapAccumE :: s -> PrimEvent (s -> (a,s)) -> PrimEvent a+    mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a     mapAccumE acc =         Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd) @@ -296,12 +253,6 @@     signum = fmap signum     fromInteger = pure . fromInteger -}---- | 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'.

@@ -14,7 +14,7 @@          -- * Main types     Event, Behavior, collect, fromCalm,-    interpretModel, interpretPushGraph,+    interpret,          -- * Core Combinators     module Control.Applicative,@@ -59,17 +59,11 @@  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.+-- | Interpretation function. -- 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)+interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b]+interpret f xs =+    map listToMaybe <$> Prim.interpret (unE . f . E) (map singleton xs)  {-----------------------------------------------------------------------------     Core Combinators

@@ -1,22 +1,22 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE CPP, Rank2Types #-}--- #define UseExtensions 1+{-# LANGUAGE Rank2Types #-}  module Reactive.Banana.Frameworks (     -- * Synopsis-    -- | Build event networks using existing event-based frameworks and run them.+    -- | Build event networks using existing event-based frameworks+    -- and run them.          -- * Simple use     interpretAsHandler,      -- * Building event networks with input/output     -- $build-    NetworkDescription, compile,+    compile, Frameworks,     AddHandler, fromAddHandler, fromChanges, fromPoll,     reactimate, initial, changes,-    liftIO, liftIOLater,+    FrameworksMoment(..), execute, liftIONow, liftIOLater,          -- * Running event networks     EventNetwork, actuate, pause,@@ -24,104 +24,61 @@     -- * Utilities     -- $utilities     newAddHandler, newEvent,+    module Reactive.Banana.Frameworks.AddHandler,          -- * Internal     interpretFrameworks,     ) where -import Control.Applicative-import Control.Concurrent.MVar import Control.Monad-import Control.Monad.Fix       (MonadFix(..))-import Control.Monad.IO.Class  (MonadIO(..))-import Control.Monad.Trans.RWS- import Data.IORef-import Data.Monoid-import qualified Data.Unique -- ordinary uniques here, because they are Ord -import Reactive.Banana.Internal.InputOutput import Reactive.Banana.Combinators--#if UseExtensions--import qualified Reactive.Banana.Internal.AST as Prim-import qualified Reactive.Banana.Internal.PushGraph as Implementation--#else--import qualified Reactive.Banana.Model as Prim-import Reactive.Banana.Internal.CompileModel--#endif--import qualified Data.Map as Map+import Reactive.Banana.Frameworks.AddHandler -type Map = Map.Map+import qualified Reactive.Banana.Internal.EventBehavior1 as Prim+import Reactive.Banana.Internal.Types2+import Reactive.Banana.Internal.Phantom  {------------------------------------------------------------------------------    Compilation specific to the different backends+    Documentation ------------------------------------------------------------------------------}-#if UseExtensions---- TODO: Share types. For that, Model.Event would need to become a newtype.--data InputToEvent = InputToEvent (forall a. InputChannel a -> PrimEvent a)-type Compile a b  = (InputToEvent -> IO (PrimEvent a,b)) -> IO (Automaton a,b)--compileWithGlobalInput :: Compile a b-compileWithGlobalInput f = do-    (e,b) <- f (InputToEvent Prim.inputE)-    a     <- Implementation.compileToAutomaton e -    return (a, b)--primChanges ~(Prim.Pair _ (Prim.Stepper x e)) = e-primInitial ~(Prim.Pair _ (Prim.Stepper x e)) = x--#else+{-$build --- types are imported by CompileModel+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? -primChanges ~(Prim.StepperB x e) = e-primInitial ~(Prim.StepperB x e) = x+The module presented here allows you to -#endif+* obtain /input/ events from external sources and to -{------------------------------------------------------------------------------    NetworkDescription, setting up event networks-------------------------------------------------------------------------------}-{-$build+* perform /output/ in reaction to events. -    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?+In constrast, the functions from "Reactive.Banana.Combinators" allow you +to express the output events in terms of the input events.+This expression is called an /event graph/. -    The module presented here 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.+An /event network/ is an event graph together with inputs and outputs.+To build an event network,+describe the inputs, outputs and event graph in the+'Moment' monad +and use the 'compile' function to obtain an event network from that. -    To /activate/ an event network, use the 'actuate' function.-    The network will register its input event handlers and start producing output.+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:-    +A typical setup looks like this:+    > main = do >   -- initialize your GUI framework >   window <- newWindow >   ... > >   -- describe the event network->   let networkDescription :: forall t. NetworkDescription t ()+>   let networkDescription :: forall t. Frameworks t => Moment t () >       networkDescription = do >           -- input: obtain  Event  from functions that register event handlers >           emouse    <- fromAddHandler $ registerMouseEvent window@@ -141,84 +98,53 @@ >           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+>   -- 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.+In short, --}+* Use 'fromAddHandler' to obtain /input/ events.+The library uses this to register event handlers with your event-based framework. -type AddHandler'     = AddHandler InputValue-type Preparations t  =-    ( [Event t (IO ())]     -- reactimate outputs-    , [AddHandler']         -- fromAddHandler events -    , [IO InputValue]       -- fromPoll events-    , [IO ()]               -- liftIOLater-    )+* Use 'reactimate' to animate /output/ events. --- | 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 InputToEvent (Preparations t) () IO a }+-} --- boilerplate class instances-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)+{-----------------------------------------------------------------------------+    Combinators+------------------------------------------------------------------------------}+singletonsE :: Prim.Event a -> Event t a+singletonsE = E . Prim.mapE (:[])  {- | Output.-    Execute the 'IO' action whenever the event occurs.-    -    -    Note: If two events occur very close to each other,-    there is no guarantee that the @reactimate@s for one -    event will have finished before the ones for the next event start executing.-    This does /not/ affect the values of events and behaviors,-    it only means that the @reactimate@ for different events may interleave.-    Fortuantely, this is a very rare occurrence, and only happens if-    -    * you call an event handler from inside 'reactimate',-    -    * or you use concurrency.+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.     -    In these cases, the @reactimate@s follow the control flow-    of your event-based framework.+Note: An event network essentially behaves like a single,+huge callback function. The 'IO' action are not run in a separate thread.+The callback function will throw an exception if one of your 'IO' actions+does so as well.+Your event-based framework will have to handle this situation.  -}-reactimate :: 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 ())+reactimate :: Frameworks t => Event t (IO ()) -> Moment t ()+reactimate = M . Prim.addReactimate . Prim.mapE sequence_ . unE  -- | Input, -- obtain an 'Event' from an 'AddHandler'.@@ -226,20 +152,8 @@ -- When the event network is actuated, -- this will register a callback function such that -- an event will occur whenever the callback function is called.-fromAddHandler :: AddHandler a -> NetworkDescription t (Event t a)-fromAddHandler addHandler = do-    (i,e) <- newInput-    let addHandler' k = addHandler $ k . toValue i . (\x -> [x])-    Prepare $ tell ([],[addHandler'],[],[])-    return e---- create a new input event from the global input event-newInput :: NetworkDescription t (InputChannel [a], Event t a)-newInput = Prepare $ do-    i <- liftIO newInputChannel-    (InputToEvent f) <- ask-    return (i, E $ f i)-+fromAddHandler :: Frameworks t => AddHandler a -> Moment t (Event t a)+fromAddHandler = M . fmap singletonsE . Prim.fromAddHandler  -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time.@@ -253,25 +167,21 @@ -- 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 = do-    (i,e) <- newInput-    let poll' = toValue i . (:[]) <$> poll-    Prepare $ tell ([],[],[poll'],[])-    initial <- liftIO $ poll-    return $ stepper initial e+fromPoll :: Frameworks t => IO a -> Moment t (Behavior t a)+fromPoll = M . fmap B . Prim.fromPoll  -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes. --  -- This is essentially just an application of the 'stepper' combinator.-fromChanges :: a -> AddHandler a -> NetworkDescription t (Behavior t a)+fromChanges :: Frameworks t => a -> AddHandler a -> Moment t (Behavior t a) fromChanges initial changes = stepper initial <$> fromAddHandler changes  -- | Output, -- observe when a 'Behavior' changes. -- --- Strictly speaking, a 'Behavior' denotes a value that varies *continuously* in time,+-- 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@@ -280,99 +190,87 @@ -- but the idea is that -- -- > changes (stepper x e) = return (calm e)-changes :: Behavior t a -> NetworkDescription t (Event t a)-changes = return . E . Prim.mapE (:[]) . primChanges . unB+--+-- WARNING: The values of the event will not become available+-- until event processing is complete. Use them within 'reactimate'.+-- If you try to access them before that, the program+-- will be thrown into an infinite loop.+changes :: Frameworks t => Behavior t a -> Moment t (Event t a)+changes = return . singletonsE . Prim.changesB . unB  -- | Output, -- observe the initial value contained in a 'Behavior'.+initial :: Behavior t a -> Moment t a+initial = M . Prim.initialB . unB+++-- | Dummy type needed to simulate impredicative polymorphism.+newtype FrameworksMoment a+    = FrameworksMoment+    { runFrameworksMoment :: forall t. Frameworks t => Moment t a }++unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a+unFM = runFrameworksMoment++-- | Dynamically add input and output to an existing event network. ----- Similar to 'updates', this function is not well-defined,--- but exists for reasons of efficiency.-initial :: Behavior t a -> NetworkDescription t a-initial = return . primInitial . unB+-- Note: You can even do 'IO' actions here, but there is no+-- guarantee about the order in which they are executed.+execute+    :: Frameworks t+    => Event t (FrameworksMoment a)+    -> Moment t (Event t a)+execute = M+    . fmap singletonsE . Prim.executeE+    . Prim.mapE (fmap last . sequence . map (unM . unFM) )+    . unE --- | Lift an 'IO' action into the 'NetworkDescription' monad,+-- | Lift an 'IO' action into the 'Moment' monad.+liftIONow :: Frameworks t => IO a -> Moment t a+liftIONow = M . Prim.liftIONow++-- | Lift an 'IO' action into the 'Moment' monad, -- but defer its execution until compilation time. -- This can be useful for recursive definitions using 'MonadFix'.-liftIOLater :: IO () -> NetworkDescription t ()-liftIOLater m = Prepare $ tell ([],[],[],[m])+liftIOLater :: Frameworks t => IO () -> Moment t ()+liftIOLater = M . Prim.liftIOLater --- | Compile a 'NetworkDescription' into an 'EventNetwork'+-- | Compile the description of an event network+-- into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on.-compile :: (forall t. NetworkDescription t ()) -> IO EventNetwork-compile m = do--    -- compile network description into an automaton-    (automaton,(inputs,polls)) <- compileWithGlobalInput $ \inputToEvent -> do-        -- execute the NetworkDescription monad-        (_,_,(outputs,inputs,polls,liftIOs)) <- runRWST (unPrepare m) inputToEvent ()-        sequence_ liftIOs                   -- execute the late IOs-        let E e = foldr union never outputs -- union of all the reactimates-        return (e, (inputs, polls))-        -    -- allocate new variable for the automaton-    rautomaton <- newEmptyMVar-    putMVar rautomaton automaton-    -    let -- run the automaton on a single input value-        run :: InputValue -> IO ()-        run input = do-            -- takeMVar  makes sure that event graph updates are atomic-            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-+--+-- Event networks are described in the 'Moment' monad+-- and use the 'Frameworks' class constraint.+compile :: (forall t. Frameworks t => Moment t ()) -> IO EventNetwork+compile m = fmap EN $ Prim.compile $ unM (m :: Moment (FrameworksD, t) ())  {-----------------------------------------------------------------------------     Running event networks ------------------------------------------------------------------------------} -- | Data type that represents a compiled event network. -- It may be paused or already running.-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 ()-    }+newtype EventNetwork = EN { unEN :: Prim.EventNetwork } --- 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+-- | Actuate an event network.+-- The inputs will register their event handlers, so that+-- the networks starts to produce outputs in response to input events.+actuate :: EventNetwork -> IO ()+actuate = Prim.actuate . unEN +-- | Pause an event network.+-- Immediately stop producing output and+-- unregister all event handlers for inputs.+-- Hence, the network stops responding to input events,+-- but it's state will be preserved.+--+-- You can resume the network with 'actuate'.+--+-- Note: You can stop a network even while it is processing events,+-- i.e. you can use 'pause' as an argument to 'reactimate'.+-- The network will /not/ stop immediately though, only after+-- the current event has been processed completely.+pause :: EventNetwork -> IO ()+pause   = Prim.pause . unEN  {-----------------------------------------------------------------------------     Simple use@@ -395,7 +293,8 @@         return bs     return bs --- | Simple way to write a single event handler with functional reactive programming.+-- | 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@@ -421,26 +320,13 @@  -} --- | Build a facility to register and unregister event handlers.-newAddHandler :: IO (AddHandler a, a -> IO ())-newAddHandler = do-    handlers <- newIORef Map.empty-    let addHandler k = do-            key <- Data.Unique.newUnique-            modifyIORef handlers $ Map.insert key k-            return $ modifyIORef handlers $ Map.delete key-        runHandlers x =-            mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers-    return (addHandler, runHandlers)-- -- | 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 :: Frameworks t => Moment t (Event t a, a -> IO ()) newEvent = do-    (addHandler, fire) <- liftIO $ newAddHandler+    (addHandler, fire) <- liftIONow $ newAddHandler     e <- fromAddHandler addHandler     return (e,fire)

@@ -0,0 +1,55 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Frameworks.AddHandler (+    -- * Synopsis+    -- | Various utility functions concerning event handlers.+    +    -- * Documentation+    AddHandler, newAddHandler,+    mapIO, filterAddHandler,+    ) where+++import Data.IORef+import qualified Data.Unique -- ordinary uniques here, because they are Ord++import qualified Data.Map as Map++type Map = Map.Map++{-----------------------------------------------------------------------------+    AddHandler+------------------------------------------------------------------------------}+-- | A value of type @AddHandler a@ is just a facility for registering+-- callback functions, also known as event handlers.+-- +-- The type is a bit mysterious, it works like this:+-- +-- > do unregisterMyHandler <- addHandler myHandler+--+-- The argument is an event handler that will be registered.+-- The return value is an action that unregisters this very event handler again.+type AddHandler a = (a -> IO ()) -> IO (IO ())++-- | Apply a function with side effects to an 'AddHandler'+mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b+mapIO f addHandler = \h -> addHandler $ \x -> f x >>= h ++-- | Filter event occurrences that don't return 'True'.+filterAddHandler :: (a -> IO Bool) -> AddHandler a -> AddHandler a+filterAddHandler f addHandler = \h ->+    addHandler $ \x -> f x >>= \b -> if b then h x else return ()++-- | Build a facility to register and unregister event handlers.+newAddHandler :: IO (AddHandler a, a -> IO ())+newAddHandler = do+    handlers <- newIORef Map.empty+    let addHandler k = do+            key <- Data.Unique.newUnique+            modifyIORef handlers $ Map.insert key k+            return $ modifyIORef handlers $ Map.delete key+        runHandlers x =+            mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers+    return (addHandler, runHandlers)+

@@ -1,215 +0,0 @@-{------------------------------------------------------------------------------    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.Unique.Really-import Data.Hashable--import qualified Reactive.Banana.Model as Model-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 (Model.Event 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---- functor-mapE f  = applyE (pureB f)---- applicative functor-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."--mapB 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 (Model.Event a))-    , keyModelB  :: !(Vault.Key (Model.Behavior a))-    }--newNode :: IO (Node a)-newNode = Node-    <$> Vault.newKey <*> Vault.newKey <*> newUnique-    <*> Vault.newKey <*> Vault.newKey--{------------------------------------------------------------------------------    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,72 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+module Reactive.Banana.Internal.Cached (+    -- | Utility for executing monadic actions once+    -- and then retrieving values from a cache.+    -- +    -- Very useful for observable sharing.+    HasVault(..),+    Cached, runCached, mkCached, fromPure,+    liftCached1, liftCached2,+    ) where++import Control.Monad+import Control.Monad.Fix+import Data.Unique.Really+import qualified Data.Vault as Vault+import System.IO.Unsafe++{-----------------------------------------------------------------------------+    Cache type+------------------------------------------------------------------------------}+data Cached m a = Cached (m a)++runCached :: Cached m a -> m a+runCached (Cached x) = x++-- | Type class for monads that have a 'Vault' that can be used.+class (Monad m, MonadFix m) => HasVault m where+    retrieve :: Vault.Key a -> m (Maybe a)+    write    :: Vault.Key a -> a -> m ()++-- | An action whose result will be cached.+-- Executing the action the first time in the monad will+-- execute the side effects. From then on,+-- only the generated value will be returned.+{-# NOINLINE mkCached #-}+mkCached :: HasVault m => m a -> Cached m a+mkCached m = unsafePerformIO $ do+    key <- Vault.newKey+    return $ Cached $ do+        ma <- retrieve key      -- look up calculation result+        case ma of+            Nothing -> mdo+                write key a     -- black-hole result first+                a <- m          -- evaluate+                return a+            Just a  -> return a -- return cached result++-- | Return a pure value.+-- Doesn't make use of the cache 'Vault'.+fromPure :: HasVault m => a -> Cached m a+fromPure = Cached . return++liftCached1+    :: HasVault m+    => (a -> m b)+    -> Cached m a -> Cached m b+liftCached1 f ca = mkCached $ do+    a <- runCached ca+    f a++liftCached2+    :: HasVault m+    => (a -> b -> m c)+    -> Cached m a -> Cached m b -> Cached m c+liftCached2 f ca cb = mkCached $ do+    a <- runCached ca+    b <- runCached cb+    f a b+

@@ -1,62 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}--module Reactive.Banana.Internal.CompileModel (-    -- * Synopsis-    -- Compile model implementation to automaton.-    -    InputToEvent(..), Compile, compileWithGlobalInput,-    ) where--import Control.Applicative-import Control.Exception (evaluate)-import Control.Monad-import Control.Monad.Trans.Reader-import Data.IORef-import Data.Maybe-import System.IO.Unsafe--import Reactive.Banana.Internal.InputOutput-import Reactive.Banana.Model--{------------------------------------------------------------------------------    Compile model to an automaton-------------------------------------------------------------------------------}-data InputToEvent = InputToEvent (forall a. InputChannel a -> Event a)-type Compile a b  = (InputToEvent -> IO (Event a,b)) -> IO (Automaton a,b)--compileWithGlobalInput :: Compile a b-compileWithGlobalInput f = do-    -- reference that holds input values-    (ref    :: IORef [InputValue]) <- newIORef undefined-    -- An infinite list of all future input values. Very unsafe!-    (inputs :: Event [InputValue]) <- unsafeSequence (Just <$> readIORef ref)-    -    let-        inputToEvent = InputToEvent $-            \i -> filterJust $ mapE (fromInputValues i) inputs-    -        filterJust = map fromJust . filter isJust-        -        fromInputValues :: InputChannel a -> [InputValue] -> Maybe a-        fromInputValues i xs = listToMaybe [y | x <- xs, Just y <- [fromValue i x]]-            --        -- step of the automaton-        step values outputs = do-            writeIORef ref values           -- write new input value-            (o:outputs) <- evaluate outputs -- make sure that output is in WHNF-            return (o, outputs)             -- return result-    -    (outputs, b) <- f inputToEvent-    return $ (fromStateful step outputs, b)---unsafeSequence :: IO a -> IO [a]-unsafeSequence m = unsafeInterleaveIO $ do-    x  <- m-    xs <- unsafeSequence m-    return (x:xs)-

@@ -0,0 +1,81 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecordWildCards #-}+module Reactive.Banana.Internal.DependencyGraph (+    -- | Utilities for operating with dependency graphs.+    Deps,+    empty, dependOn, topologicalSort, +    ) where++import Data.Hashable+import qualified Data.HashMap.Lazy as Map+import qualified Data.HashSet as Set++type Map = Map.HashMap+type Set = Set.HashSet++{-----------------------------------------------------------------------------+    Dependency graph data type+------------------------------------------------------------------------------}+-- depdendency graph+data Deps a = Deps+    { dChildren :: Map a [a] -- children depend on their parents+    , dParents  :: Map a [a]+    , dRoots    :: Set a+    } deriving (Eq,Show)++-- convenient queries+children deps x = maybe [] id . Map.lookup x $ dChildren deps+parents  deps x = maybe [] id . Map.lookup x $ dParents  deps++-- the empty dependency graph+empty :: Hashable a => Deps a+empty = Deps+    { dChildren = Map.empty+    , dParents  = Map.empty+    , dRoots    = Set.empty+    }++{-----------------------------------------------------------------------------+    Operations+------------------------------------------------------------------------------}+-- add a dependency to the graph+dependOn :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a+dependOn x y deps0 = deps1+    where+    deps1 = deps0+        { dChildren = Map.insertWith (++) y [x] $ dChildren deps0+        , dParents  = Map.insertWith (++) x [y] $ dParents  deps0+        , dRoots    = roots+        }+    +    roots = when (null $ parents deps0 x) (Set.delete x)+          . when (null $ parents deps1 y) (Set.insert y)+          $ dRoots deps0+    +    when b f = if b then f else id++-- order the nodes in a way such that no children comes before its parent+topologicalSort :: (Eq a, Hashable a) => Deps a -> [a]+topologicalSort deps = go (Set.toList $ dRoots deps) Set.empty+    where+    go []     _     = []+    go (x:xs) seen1 = x : go (adultChildren ++ xs) seen2+        where+        seen2         = Set.insert x seen1+        adultChildren = filter isAdult (children deps x)+        isAdult y     = all (`Set.member` seen2) (parents deps y)++{-----------------------------------------------------------------------------+    Small tests+------------------------------------------------------------------------------}+test = id+    . dependOn 'D' 'C'+    . dependOn 'D' 'B'+    . dependOn 'C' 'B'+    . dependOn 'B' 'A'+    . dependOn 'B' 'a'+    $ empty++

@@ -0,0 +1,172 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+module Reactive.Banana.Internal.EventBehavior1 (+    -- * Interpreter+    interpret, compile,+    +    -- * Basic combinators+    Event, Behavior,+    never, filterJust, unionWith, mapE, accumE, applyE,+    changesB, stepperB, pureB, applyB, mapB,+    +    -- * Dynamic event switching+    Moment,+    initialB, trimE, trimB, executeE, observeE, switchE, switchB,+    +    -- * Setup and IO+    addReactimate, fromAddHandler, fromPoll, liftIONow, liftIOLater,+    EventNetwork, pause, actuate,+    ) where++import Data.Functor+import Data.Functor.Identity+import Control.Monad (join, (<=<))+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (lift)++import qualified Reactive.Banana.Internal.PulseLatch0 as Prim+import Reactive.Banana.Internal.Cached+import Reactive.Banana.Internal.InputOutput+import Reactive.Banana.Frameworks.AddHandler++type Network = Prim.Network+type Latch   = Prim.Latch+type Pulse   = Prim.Pulse++{-----------------------------------------------------------------------------+    Types+------------------------------------------------------------------------------}+type Behavior a = Cached Network (Latch a, Pulse ())+type Event a    = Cached Network (Pulse a)+type Moment     = Prim.NetworkSetup++runCachedM :: Cached Network a -> Moment a+runCachedM = Prim.liftNetwork . runCached++{-----------------------------------------------------------------------------+    Interpretation+------------------------------------------------------------------------------}+inputE :: InputChannel a -> Event a+inputE = mkCached . Prim.inputP++interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpret f = Prim.interpret (\pulse -> runCachedM =<< f (fromPure pulse))++compile :: Moment () -> IO EventNetwork+compile = Prim.compile++{-----------------------------------------------------------------------------+    Combinators - basic+------------------------------------------------------------------------------}+never       = mkCached $ Prim.neverP+unionWith f = liftCached2 $ Prim.unionWith f+filterJust  = liftCached1 $ Prim.filterJustP+accumE x    = liftCached1 $ Prim.accumP x+mapE f      = liftCached1 $ Prim.mapP f+applyE      = liftCached2 $ \(lf,_) px -> Prim.applyP lf px++changesB    = liftCached1 $ \(lx,px) -> Prim.tagFuture lx px++-- Note: to enable more recursion,+-- first create the latch and then create the event that is accumulated+stepperB a  = \c1 -> mkCached $ mdo+    l  <- Prim.stepperL a p1+    p1 <- runCached c1+    p2 <- Prim.mapP (const ()) p1+    return (l,p2)++pureB a = stepperB a never+applyB = liftCached2 $ \(l1,p1) (l2,p2) -> do+    p3 <- Prim.unionWith const p1 p2+    l3 <- Prim.applyL l1 l2+    return (l3,p3)+mapB f = applyB (pureB f)++{-----------------------------------------------------------------------------+    Combinators - dynamic event switching+------------------------------------------------------------------------------}+initialB :: Behavior a -> Moment a+initialB b = Prim.liftNetwork $ do+    ~(l,_) <- runCached b+    Prim.valueL l++trimE :: Event a -> Moment (Moment (Event a))+trimE e = do+    p <- runCachedM e                  -- add pulse to network+    -- NOTE: if the pulse is not connected to an input node,+    -- it will be garbage collected right away.+    -- TODO: Do we need to check for this?+    return $ return $ fromPure p       -- remember it henceforth++trimB :: Behavior a -> Moment (Moment (Behavior a))+trimB b = do+    ~(l,p) <- runCachedM b             -- add behavior to network+    return $ return $ fromPure (l,p)   -- remember it henceforth+++observeE :: Event (Moment a) -> Event a +observeE = liftCached1 $ Prim.executeP++executeE :: Event (Moment a) -> Moment (Event a)+executeE e = Prim.liftNetwork $ do+    p <- runCached e+    result <- Prim.executeP p+    return $ fromPure result++switchE :: Event (Moment (Event a)) -> Event a+switchE = liftCached1 $ \p1 -> do+    p2 <- Prim.mapP (runCachedM =<<) p1+    p3 <- Prim.executeP p2+    Prim.switchP p3++switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a+switchB = liftCached2 $ \(l0,p0) p1 -> do+    p2 <- Prim.mapP (runCachedM =<<) p1+    p3 <- Prim.executeP p2+    lr <- Prim.switchL l0 =<< Prim.mapP fst p3++    -- TODO: switch away the initial behavior+    let c1 = p0                              -- initial behavior changes+    c2 <- Prim.mapP (const ()) p3            -- or switch happens+    c3 <- Prim.switchP =<< Prim.mapP snd p3  -- or current behavior changes+    pr <- merge c1 =<< merge c2 c3+    return (lr, pr)++merge = Prim.unionWith (\_ _ -> ())++{-----------------------------------------------------------------------------+    Combinators - Setup and IO+------------------------------------------------------------------------------}+addReactimate :: Event (IO ()) -> Moment ()+addReactimate e = do+    p <- runCachedM e+    lift $ Prim.addReactimate p++liftIONow :: IO a -> Moment a+liftIONow = liftIO++liftIOLater :: IO () -> Moment ()+liftIOLater = lift . Prim.liftIOLater++fromAddHandler :: AddHandler a -> Moment (Event a)+fromAddHandler addHandler = do+    i <- liftIO newInputChannel+    p <- Prim.liftNetwork $ Prim.inputP i+    lift $ Prim.registerHandler $ mapIO (return . (:[]) . toValue i) addHandler+    return $ fromPure p++fromPoll :: IO a -> Moment (Behavior a)+fromPoll poll = do+    a <- liftIO poll+    e <- Prim.liftNetwork $ do+        pm <- Prim.mapP (const $ liftIO poll) Prim.alwaysP+        p  <- Prim.executeP pm+        return $ fromPure p+    return $ stepperB a e++type EventNetwork = Prim.EventNetwork+pause   = Prim.pause+actuate = Prim.actuate

@@ -62,10 +62,10 @@     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+unfoldAutomaton :: Automaton b -> InputChannel a -> [Maybe a] -> IO [Maybe b]+unfoldAutomaton _    _ []       = return []+unfoldAutomaton auto i (mx:mxs) = do+    (b, auto) <- runStep auto $ maybe [] (\x -> [toValue i x]) mx+    bs        <- unfoldAutomaton auto i mxs     return (b:bs)     

@@ -1,75 +0,0 @@-{------------------------------------------------------------------------------    reactive-banana-------------------------------------------------------------------------------}-module Reactive.Banana.Internal.InterpretModel (-    -- * Synopsis-    -- | Interpret abstract syntax with model implementation.-    -    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-import Reactive.Banana.Model as Model hiding (interpretModel)--{------------------------------------------------------------------------------    Interpret AST with model,-    pay 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)-    -> Model.Event a -> IO (Model.Event b)-interpretModel f input = do-    i0 <- newInputChannel-    -    let-        evalE :: AST.EventD AST.Expr a -> Eval (Model.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 (Model.Behavior a)-        evalB (AST.Stepper x e) = stepperB x <$> goE e-        evalB _                 =-            error "Reactive.Banana.PushIO.interpretModel: internal error: B"--        goE :: AST.Event AST.Expr a -> Eval (Model.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 (Model.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,23 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}+module Reactive.Banana.Internal.Phantom (+    -- * Synopsis+    -- | Classes used to constrain the phantom type @t@ in the 'Moment' type.+    +    -- * Documentation+    Frameworks, FrameworksD,+    ) where++import Reactive.Banana.Internal.Types2++-- | Class constraint on the type parameter @t@ of the 'Moment' monad.+-- +-- Indicates that we can add input and output to an event network.+class Frameworks t++-- | Data type for discharging the 'Frameworks' constraint.+data FrameworksD++instance Frameworks (FrameworksD,t)

@@ -0,0 +1,568 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, RecursiveDo, ExistentialQuantification,+    TypeSynonymInstances #-}+module Reactive.Banana.Internal.PulseLatch0 where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.RWS+import Control.Monad.IO.Class++import Data.IORef+import Data.Monoid (Endo(..))++import Control.Concurrent.MVar++import Reactive.Banana.Internal.Cached+import Reactive.Banana.Internal.InputOutput+import qualified Reactive.Banana.Internal.DependencyGraph as Deps+import Reactive.Banana.Frameworks.AddHandler++import Data.Hashable+import Data.Unique.Really+import qualified Data.Vault as Vault+import qualified Data.HashMap.Lazy as Map++import Data.Functor.Identity+import System.IO.Unsafe++import Debug.Trace++type Map  = Map.HashMap+type Deps = Deps.Deps++debug   s m = m+debugIO s m = liftIO (putStrLn s) >> m++{-----------------------------------------------------------------------------+    Graph data type+------------------------------------------------------------------------------}+data Graph = Graph+    { grPulse   :: Values                    -- pulse values+    , grLatch   :: Values                    -- latch values+    +    , grCache   :: Values                    -- cache for initialization++    , grDeps    :: Deps SomeNode             -- dependency information+    , grInputs  :: [Input]                   -- input  nodes+    }++type Values = Vault.Vault+type Key    = Vault.Key+type Input  =+    ( SomeNode+    , InputValue -> Values -> Values         -- write input value into graph+    )++emptyGraph :: Graph+emptyGraph = Graph+    { grPulse  = Vault.empty+    , grLatch  = Vault.empty+    , grCache  = Vault.empty+    , grDeps   = Deps.empty+    , grInputs = [(P alwaysP, const id)]+    }++{-----------------------------------------------------------------------------+    Graph evaluation+------------------------------------------------------------------------------}+-- evaluate all the nodes in the graph once+evaluateGraph :: [InputValue] -> Graph -> Setup Graph+evaluateGraph inputs = fmap snd+    . uncurry (runNetworkAtomicT . performEvaluation)+    . buildEvaluationOrder+    . writeInputValues inputs++runReactimates (graph,reactimates) =+        sequence_ [action | pulse <- reactimates+                          , Just action <- [readPulseValue pulse graph]]+readPulseValue p = getValueP p . grPulse++writeInputValues inputs graph = graph { grPulse =+    concatenate [f x | (_,f) <- grInputs graph, x <- inputs] Vault.empty }++concatenate :: [a -> a] -> (a -> a)+concatenate = foldr (.) id++performEvaluation :: [SomeNode] -> NetworkSetup ()+performEvaluation = mapM_ evaluate+    where+    evaluate (P p) = evaluateP p+    evaluate (L l) = liftNetwork $ evaluateL l++-- Figure out which nodes need to be evaluated.+--+-- All nodes that are connected to current input nodes must be evaluated.+-- The other nodes don't have to be evaluated, because they yield+-- Nothing / don't change anyway.+buildEvaluationOrder :: Graph -> ([SomeNode], Graph)+buildEvaluationOrder graph = (Deps.topologicalSort $ grDeps graph, graph)+++{-----------------------------------------------------------------------------+    Network monad+------------------------------------------------------------------------------}+-- The 'Network' monad is used for evaluation and changes+-- the state of the graph.+type NetworkT     = RWST Graph (Endo Graph) Graph+type Network      = NetworkT Identity+type NetworkSetup = NetworkT Setup++-- lift pure Network computation into any monad+-- very useful for its laziness+liftNetwork :: Monad m => Network a -> NetworkT m a+liftNetwork m = RWST $ \r s -> return . runIdentity $ runRWST m r s++-- access initialization cache+instance (MonadFix m, Functor m) => HasVault (NetworkT m) where+    retrieve key = Vault.lookup key . grCache <$> get+    write key a  = modify $ \g -> g { grCache = Vault.insert key a (grCache g) }++-- change a graph "atomically"+runNetworkAtomicT :: MonadFix m => NetworkT m a -> Graph -> m (a, Graph)+runNetworkAtomicT m g1 = mdo+    (x, g2, w2) <- runRWST m g3 g1  -- apply early graph gransformations+    let g3 = appEndo w2 g2          -- apply late  graph transformations+    return (x, g3)++-- write pulse value immediately+writePulse :: Key (Maybe a) -> Maybe a -> Network ()+writePulse key x =+    modify $ \g -> g { grPulse = Vault.insert key x $ grPulse g }++-- read pulse value immediately+readPulse :: Key (Maybe a) -> Network (Maybe a)+readPulse key = (getPulse key . grPulse) <$> get++getPulse key = join . Vault.lookup key++-- write latch value immediately+writeLatch :: Key a -> a -> Network ()+writeLatch key x =+    modify $ \g -> g { grLatch = Vault.insert key x $ grLatch g }++-- read latch value immediately+readLatch :: Key a -> Network a+readLatch key = (maybe err id . Vault.lookup key . grLatch) <$> get+    where err = error "readLatch: latch not initialized!"++-- write latch value for future+writeLatchFuture :: Key a -> a -> Network ()+writeLatchFuture key x =+    tell $ Endo $ \g -> g { grLatch = Vault.insert key x $ grLatch g }++-- read future latch value+-- Note [LatchFuture]:+--   warning: forcing the value early will likely result in an infinite loop+readLatchFuture :: Key a -> Network a+readLatchFuture key = (maybe err id . Vault.lookup key . grLatch) <$> ask+    where err = error "readLatchFuture: latch not found!"++-- add a dependency+dependOn :: SomeNode -> SomeNode -> Network ()+dependOn x y = modify $ \g -> g { grDeps = Deps.dependOn x y $ grDeps g }++dependOns :: SomeNode -> [SomeNode] -> Network ()+dependOns x = mapM_ $ dependOn x++-- link a Pulse key to an input channel+addInput :: Key (Maybe a) -> Pulse a -> InputChannel a -> Network ()+addInput key pulse channel =+    modify $ \g -> g { grInputs = (P pulse, input) : grInputs g }+    where+    input value+        | getChannel value == getChannel channel =+            Vault.insert key (fromValue channel value)+        | otherwise = id++{-----------------------------------------------------------------------------+    Setup monad+------------------------------------------------------------------------------}+{-+    The 'Setup' monad allows us to do administrative tasks+    during graph evaluation.+    For instance, we can+        * add new reactimates+        * perform IO+-}++type Reactimate = Pulse (IO ())+type SetupConf  =+    ( [Reactimate]                -- reactimate+    , [AddHandler [InputValue]]   -- fromAddHandler+    , [IO ()]                     -- liftIOLater+    )+type Setup  = RWST () SetupConf () IO++addReactimate :: Reactimate -> Setup ()+addReactimate x = tell ([x],[],[])++liftIOLater :: IO () -> Setup ()+liftIOLater x = tell ([],[],[x])++discardSetup :: Setup a -> IO a+discardSetup m = do+    (a,_,_) <- runRWST m () ()+    return a++registerHandler :: AddHandler [InputValue] -> Setup ()+registerHandler x = tell ([],[x],[])++runSetup :: Callback -> Setup a -> IO (a, [Reactimate])+runSetup callback m = do+    (a,_,(reactimates,addHandlers,liftIOLaters)) <- runRWST m () ()+    mapM_ ($ callback) addHandlers  -- register new event handlers+    sequence_ liftIOLaters          -- execute late IOs+    return (a,reactimates)++{-----------------------------------------------------------------------------+    Compilation.+    State machine IO stuff.+------------------------------------------------------------------------------}+type Callback = [InputValue] -> IO ()++data EventNetwork = EventNetwork+    { actuate :: IO ()+    , pause   :: IO ()+    }++-- compile to an event network+compile :: NetworkSetup () -> IO EventNetwork+compile setup = do+    actuated <- newIORef False                   -- flag to set running status+    rstate   <- newEmptyMVar                     -- setup callback machinery+    let+        whenFlag flag action = readIORef flag >>= \b -> when b action+        callback inputs = whenFlag actuated $ do+            state0 <- takeMVar rstate            -- read and take lock+            -- pollValues <- sequence polls      -- poll mutable data+            (reactimates, state1)+                <- step inputs state0            -- calculate new state+            putMVar rstate state1                -- write state+            reactimates                          -- run IO actions afterwards++            -- register event handlers+            -- register :: IO (IO ())+            -- register = fmap sequence_ . sequence . map ($ run) $ inputs++        step inputs (g0,r0) = do                 -- evaluation function+            (g2,r1) <- runSetup callback $ evaluateGraph inputs g0+            let+                r2     = r0 ++ r1                -- concatenate reactimates+                runner = runReactimates (g2,r2)  -- don't run them yet!+            return (runner, (g2,r2))++    ((_,graph), reactimates)                     -- compile initial graph+        <- runSetup callback $ runNetworkAtomicT setup emptyGraph+    putMVar rstate (graph,reactimates)           -- set initial state+        +    return $ EventNetwork+        { actuate = writeIORef actuated True+        , pause   = writeIORef actuated False+        }++-- make an interpreter+interpret :: (Pulse a -> NetworkSetup (Pulse b)) -> [Maybe a] -> IO [Maybe b]+interpret f xs = do+    i <- newInputChannel+    (result,graph) <- discardSetup $+        runNetworkAtomicT (f =<< liftNetwork (inputP i)) emptyGraph++    let+        step Nothing  g0 = return (Nothing,g0)+        step (Just a) g0 = do+            g1 <- discardSetup $ evaluateGraph [toValue i a] g0+            return (readPulseValue result g1, g1)+    +    mapAccumM step graph xs++mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]+mapAccumM _ _  []     = return []+mapAccumM f s0 (x:xs) = do+    (b,s1) <- f x s0+    bs     <- mapAccumM f s1 xs+    return (b:bs)++{-----------------------------------------------------------------------------+    Pulse and Latch types+------------------------------------------------------------------------------}+{-+    evaluateL/P+        calculates the next value and makes sure that it's cached+    valueL/P+        retrieves the current value+    futureL+        future value of the latch+        see note [LatchFuture]+    uidL/P+        used for dependency tracking and evaluation order+-}++data Pulse a = Pulse+    { evaluateP :: NetworkSetup ()+    , getValueP :: Values -> Maybe a+    , uidP      :: Unique+    }++data Latch a = Latch+    { evaluateL :: Network ()+    , valueL    :: Network a+    , futureL   :: Network a+    , uidL      :: Unique+    }+++valueP :: Pulse a -> Network (Maybe a)+valueP p = getValueP p . grPulse <$> get++{-+* Note [LatchCreation]++When creating a new latch from a pulse, we assume that the+pulse cannot fire at the moment that the latch is created.+This is important when switching latches, because of note [PulseCreation].++Likewise, when creating a latch, we assume that we do not+have to calculate the previous latch value.++* Note [PulseCreation]++We assume that we do not have to calculate a pulse occurrence+at the moment we create the pulse. Otherwise, we would have+to recalculate the dependencies *while* doing evaluation;+this is a recipe for desaster.+++* Note [unsafePerformIO]++We're using @unsafePerformIO@ only to get @Key@ and @Unique@.+It's not great, but it works.++Unfortunately, using @IO@ as the base of the @Network@ monad+transformer doens't work because it doesn't support recursion+and @mfix@ very well.++We could use the @ST@ monad, but this would add a type parameter+to everything. A refactoring of this scope is too annoying for+my taste right now.++-}++-- make pulse from evaluation function+pulse' :: NetworkSetup (Maybe a) -> Network (Pulse a)+pulse' eval = unsafePerformIO $ do+    key <- Vault.newKey+    uid <- newUnique+    return $ return $ Pulse+        { evaluateP = liftNetwork . writePulse key =<< eval+        , getValueP = getPulse key+        , uidP      = uid+        }++pulse :: Network (Maybe a) -> Network (Pulse a)+pulse = pulse' . liftNetwork++neverP :: Network (Pulse a)+neverP = debug "neverP" $ unsafePerformIO $ do+    uid <- newUnique+    return $ return $ Pulse+        { evaluateP = return ()+        , getValueP = const Nothing+        , uidP      = uid+        }++-- create a pulse that listens to input values+inputP :: InputChannel a -> Network (Pulse a)+inputP channel = debug "inputP" $ unsafePerformIO $ do+    key <- Vault.newKey+    uid <- newUnique+    return $ do+        let+            p = Pulse+                { evaluateP = return ()+                , getValueP = getPulse key+                , uidP      = uid+                }+        addInput key p channel+        return p++-- event that always fires whenever the network processes events+alwaysP :: Pulse ()+alwaysP = debug "alwaysP" $ unsafePerformIO $ do+    uid <- newUnique+    return $ Pulse+        { evaluateP = return ()+        , getValueP = return $ Just ()+        , uidP      = uid+        }++-- make latch from initial value, a future value and evaluation function+latch :: a -> a -> Network (Maybe a) -> Network (Latch a)+latch now future eval = unsafePerformIO $ do+    key <- Vault.newKey+    uid <- newUnique+    return $ do+        -- Initialize with current and future latch value.+        -- See note [LatchCreation].+        writeLatch key now+        writeLatchFuture key future+        +        return $ Latch+            { evaluateL = maybe (return ()) (writeLatchFuture key) =<< eval+            , valueL    = readLatch key+            , futureL   = readLatchFuture key+            , uidL      = uid+            }++pureL :: a -> Network (Latch a)+pureL a = debug "pureL" $ unsafePerformIO $ do+    uid <- liftIO newUnique+    return $ return $ Latch+        { evaluateL = return ()+        , valueL    = return a+        , futureL   = return a+        , uidL      = uid+        }++{-----------------------------------------------------------------------------+    Existential quantification over Pulse and Latch+    for dependency tracking+------------------------------------------------------------------------------}+data SomeNode = forall a. P (Pulse a) | forall a. L (Latch a)++instance Eq SomeNode where+    (L x) == (L y)  =  uidL x == uidL y+    (P x) == (P y)  =  uidP x == uidP y+    _     == _      =  False++instance Hashable SomeNode where+    hashWithSalt s (P p) = hashWithSalt s $ uidP p+    hashWithSalt s (L l) = hashWithSalt s $ uidL l++{-----------------------------------------------------------------------------+    Combinators - basic+------------------------------------------------------------------------------}+stepperL :: a -> Pulse a -> Network (Latch a)+stepperL a p = debug "stepperL" $ do+    -- @a@ is indeed the future latch value. See note [LatchCreation].+    x <- latch a a (valueP p)+    L x `dependOn` P p+    return x++accumP :: a -> Pulse (a -> a) -> Network (Pulse a)+accumP a p = debug "accumP" $ mdo+        x       <- stepperL a result+        result  <- pulse $ eval <$> valueL x <*> valueP p+        -- Evaluation order of the result pulse does *not*+        -- depend on the latch. It does depend on latch value,+        -- though, so don't garbage collect that one.+        P result `dependOn` P p+        return result+    where+    eval _ Nothing  = Nothing+    eval x (Just f) = let y = f x in y `seq` Just y  -- strict evaluation++applyP :: Latch (a -> b) -> Pulse a -> Network (Pulse b)+applyP f x = debug "applyP" $ do+    result <- pulse $ fmap <$> valueL f <*> valueP x+    P result `dependOn` P x+    return result++-- tag a pulse with future values of a latch+-- Caveat emptor.+tagFuture :: Latch a -> Pulse b -> Network (Pulse a)+tagFuture f x = debug "tagFuture" $ do+    result <- pulse $ fmap . const <$> futureL f <*> valueP x+    P result `dependOn` P x+    return result++mapP :: (a -> b) -> Pulse a -> Network (Pulse b)+mapP f p = debug "mapP" $ do+    result <- pulse $ fmap f <$> valueP p+    P result `dependOn` P p+    return result++filterJustP :: Pulse (Maybe a) -> Network (Pulse a)+filterJustP p = debug "filterJustP" $ do+    result <- pulse $ join <$> valueP p+    P result `dependOn` P p+    return result++unionWith :: (a -> a -> a) -> Pulse a -> Pulse a -> Network (Pulse a)+unionWith f px py = debug "unionWith" $ do+        result <- pulse $ eval <$> valueP px <*> valueP py+        P result `dependOns` [P px, P py]+        return result+    where+    eval (Just x) (Just y) = Just (f x y)+    eval (Just x) Nothing  = Just x+    eval Nothing  (Just y) = Just y+    eval Nothing  Nothing  = Nothing+++applyL :: Latch (a -> b) -> Latch a -> Network (Latch b)+applyL lf lx = debug "applyL" $ do+        -- The value in the next cycle is always the future value.+    -- See note [LatchCreation]+    let eval = ($) <$> futureL lf <*> futureL lx+    future <- eval+    now    <- ($) <$> valueL lf <*> valueL lx+    result <- latch now future $ fmap Just eval+    L result `dependOns` [L lf, L lx]+    return result++{-----------------------------------------------------------------------------+    Combinators - dynamic event switching+------------------------------------------------------------------------------}+executeP :: Pulse (NetworkSetup a) -> Network (Pulse a)+executeP pn = do+    result <- pulse' $ do+        mp <- liftNetwork $ valueP pn+        case mp of+            Just p  -> Just <$> p+            Nothing -> return Nothing+    P result `dependOn` P pn+    return result++switchP :: Pulse (Pulse a) -> Network (Pulse a)+switchP pp = mdo+    never <- neverP+    lp    <- stepperL never pp+    let+        eval = do+            newPulse <- valueP pp+            case newPulse of+                Nothing -> return ()+                Just p  -> P result `dependOn` P p  -- check in new pulse+            valueP =<< valueL lp                    -- fetch value from old pulse+            -- we have to use the *old* event value due to note [LatchCreation]+    result <- pulse eval+    P result `dependOns` [L lp, P pp]+    return result+++switchL :: Latch a -> Pulse (Latch a) -> Network (Latch a)+switchL l p = mdo+    ll <- stepperL l p+    let+        -- switch to a new latch+        switchTo l = do+            L result `dependOn` L l+            futureL l+        -- calculate future value of the result latch+        eval = do+            mp <- valueP p+            case mp of+                Nothing -> futureL =<< valueL ll+                Just l  -> switchTo l++    now    <- valueL  l                 -- see note [LatchCreation]+    future <- futureL l+    result <- latch now future $ Just <$> eval+    L result `dependOns` [L l, P p]+    return result++

@@ -1,410 +0,0 @@-{------------------------------------------------------------------------------    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---

@@ -1,123 +0,0 @@-{------------------------------------------------------------------------------    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)--

@@ -0,0 +1,59 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Internal.Types2 (+    -- | Primitive types.+    Event (..), Behavior (..), Moment (..)+    ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix++import qualified Reactive.Banana.Internal.EventBehavior1 as Prim+++{-| @Event t a@ represents a stream of events as they occur in time.+Semantically, you can think of @Event t a@ as an infinite list of values+that are tagged with their corresponding time of occurence,++> type Event t a = [(Time,a)]+-}+newtype Event t a = E { unE :: Prim.Event [a] }++{-| @Behavior t a@ represents a value that varies in time. Think of it as++> type Behavior t a = Time -> a+-}+newtype Behavior t a = B { unB :: Prim.Behavior a }++{-| The 'Moment' monad denotes a value at a particular /moment in time/.++This monad is not very interesting, it is mainly used for book-keeping.+In particular, the type parameter @t@ is used+to disallow various unhealthy programs.++This monad is also used to describe event networks+in the "Reactive.Banana.Frameworks" module.+This only happens when the type parameter @t@+is constrained by the 'Frameworks' class.++To be precise, an expression of type @Moment t a@ denotes+a value of type @a@ that is observed at a moment in time+which is indicated by the type parameter @t@.++-}+newtype Moment t a = M { unM :: Prim.Moment a }+++-- boilerplate class instances+instance Monad (Moment t) where+    return  = M . return+    m >>= g = M $ unM m >>= unM . g++instance Applicative (Moment t) where+    pure    = M . pure+    f <*> a = M $ unM f <*> unM a++instance MonadFix (Moment t) where   mfix f  = M $ mfix (unM . f)+instance Functor  (Moment t) where   fmap f  = M . fmap f . unM

@@ -9,15 +9,21 @@     -- $model      -- * Combinators-    Event(..), Behavior(..),-    never, filterE, unionWith, applyE, accumE, stepperB,-    mapE, pureB, applyB, mapB,-    +    -- ** Data types+    Event, Behavior,+    -- ** Basic+    never, filterJust, unionWith, mapE, accumE, applyE,+    stepperB, pureB, applyB, mapB,+    -- ** Dynamic event switching+    Moment,+    initialB, trimE, trimB, observeE, switchE, switchB,+             -- * Interpretation-    interpretModel,+    interpret,     ) where  import Control.Applicative+import Control.Monad (join)  {-$model @@ -40,16 +46,19 @@ -}  {------------------------------------------------------------------------------    Combinators+    Basic Combinators ------------------------------------------------------------------------------}-type Event a    = [Maybe a]-data Behavior a = StepperB a (Event a)+type Event a    = [Maybe a]             -- should be abstract+data Behavior a = StepperB a (Event a)  -- should be abstract +interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]+interpret f e = f e 0+ never :: Event a never = repeat Nothing -filterE :: (a -> Bool) -> Event a -> Event a-filterE p = map (>>= \x -> if p x then Just x else Nothing)+filterJust :: Event (Maybe a) -> Event a+filterJust = map join  unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a unionWith f = zipWith g@@ -59,6 +68,8 @@     g Nothing  (Just y) = Just y     g Nothing  Nothing  = Nothing +mapE f  = applyE (pureB f)+ applyE :: Behavior (a -> b) -> Event a -> Event b applyE _               []     = [] applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs@@ -71,12 +82,9 @@ accumE x (Nothing:fs) = Nothing : accumE x fs accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs)  -stepperB :: a -> [Maybe a] -> Behavior a+stepperB :: a -> Event a -> Behavior a stepperB = StepperB --- functor-mapE f  = applyE (pureB f)- -- applicative functor pureB x = stepperB x never @@ -90,5 +98,54 @@  mapB f = applyB (pureB f) -interpretModel :: (Event a -> Event b) -> Event a -> IO (Event b)-interpretModel = (return .)+{-----------------------------------------------------------------------------+    Dynamic Event Switching+------------------------------------------------------------------------------}+type Time     = Int+type Moment a = Time -> a     -- should be abstract++{-+instance Monad Moment where+    return  = const+    m >>= g = \time -> g (m time) time+-}++initialB :: Behavior a -> Moment a+initialB (StepperB x _) = return x++trimE :: Event a -> Moment (Moment (Event a))+trimE e = \now -> \later -> drop (later - now) e++trimB :: Behavior a -> Moment (Moment (Behavior a))+trimB b = \now -> \later -> bTrimmed !! (later - now)+    where+    bTrimmed = iterate drop1 b++    drop1 (StepperB x []          ) = StepperB x never+    drop1 (StepperB x (Just y :ys)) = StepperB y ys+    drop1 (StepperB x (Nothing:ys)) = StepperB x ys++observeE :: Event (Moment a) -> Event a+observeE = zipWith (\time -> fmap ($ time)) [0..]++switchE :: Event (Moment (Event a)) -> Event a+switchE = step never . observeE+    where+    step ys     []           = ys+    step (y:ys) (Nothing:xs) = y : step ys xs +    step (y:ys) (Just zs:xs) = y : step (drop 1 zs) xs+    -- assume that the dynamic events are at least as long as the+    -- switching event++switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a+switchB (StepperB x e) = stepperB x . step e . observeE+    where+    step ys     []                        = ys+    step (y:ys) (Nothing             :xs) =          y : step ys xs +    step (y:ys) (Just (StepperB x zs):xs) = Just value : step (drop 1 zs) xs+        where+        value = case zs of+            Just z : _ -> z -- new behavior changes right away+            _          -> x -- new behavior stays constant for a while++

@@ -0,0 +1,94 @@+{-----------------------------------------------------------------------------+    Reactive Banana+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances #-}++module Reactive.Banana.Switch (+    -- * Synopsis+    -- | Dynamic event switching.+    +    -- * Moment monad+    Moment, AnyMoment, anyMoment, now,+    +    -- * Dynamic event switching+    trimE, trimB,+    switchE, switchB,+    observeE, valueB,+    +    -- * Identity Functor+    Identity(..),+    ) where++import Control.Applicative+import Control.Monad++import Reactive.Banana.Combinators+import qualified Reactive.Banana.Internal.EventBehavior1 as Prim+import Reactive.Banana.Internal.Types2++{-----------------------------------------------------------------------------+    Constant+------------------------------------------------------------------------------}+-- | Identity functor with a dummy argument.+-- Unlike 'Data.Functor.Constant',+-- this functor is constant in the /second/ argument.++data Identity t a = Identity { getIdentity :: a }++instance Functor (Identity t) where+    fmap f (Identity a) = Identity (f a)++{-----------------------------------------------------------------------------+    Moment+------------------------------------------------------------------------------}+-- | Value present at any/every moment in time.+newtype AnyMoment f a = AnyMoment { now :: forall t. Moment t (f t a) }++instance Monad (AnyMoment Identity) where+    return x = AnyMoment $ return (Identity x)+    (AnyMoment m) >>= g = AnyMoment $ m >>= \(Identity x) -> now (g x)++instance Functor (AnyMoment Behavior) where+    fmap f (AnyMoment x) = AnyMoment (fmap (fmap f) x)++instance Applicative (AnyMoment Behavior) where+    pure x  = AnyMoment $ return $ pure x+    (AnyMoment f) <*> (AnyMoment x) = AnyMoment $ liftM2 (<*>) f x++anyMoment :: (forall t. Moment t (f t a)) -> AnyMoment f a+anyMoment = AnyMoment++{-----------------------------------------------------------------------------+    Dynamic event switching+------------------------------------------------------------------------------}+-- | Trim an 'Event' to a variable start time.+trimE :: Event t a -> Moment t (AnyMoment Event a)+trimE = M . fmap (\x -> AnyMoment (M $ fmap E x)) . Prim.trimE . unE++-- | Trim a 'Behavior' to a variable start time.+trimB :: Behavior t a -> Moment t (AnyMoment Behavior a)+trimB = M . fmap (\x -> AnyMoment (M $ fmap B x)) . Prim.trimB . unB++-- | Observe a value at those moments in time where+-- event occurrences happen.+observeE :: Event t (AnyMoment Identity a) -> Event t a+observeE = E . Prim.observeE+    . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE++-- | Obtain the value of the 'Behavior' at moment @t@.+valueB :: Behavior t a -> Moment t a+valueB = M . Prim.initialB . unB++-- | Dynamically switch between 'Event'.+switchE+    :: forall t a. Event t (AnyMoment Event a)+    -> Event t a+switchE = E . Prim.switchE . Prim.mapE (fmap unE . unM . now . last) . unE++-- | Dynamically switch between 'Behavior'.+switchB+    :: forall t a. Behavior t a+    -> Event t (AnyMoment Behavior a)+    -> Behavior t a+switchB b e = B $ Prim.switchB (unB b) $+    Prim.mapE (fmap unB . unM . now . last) (unE e)

@@ -0,0 +1,168 @@+{-----------------------------------------------------------------------------+    reactive-banana++    Test cases and examples+------------------------------------------------------------------------------}+{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}++import Control.Monad (when, join)++import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit (testCase)++import Test.HUnit (assert, Assertion)++-- import Test.QuickCheck+-- import Test.QuickCheck.Property++import Control.Applicative+import Reactive.Banana.Test.Plumbing+++main = defaultMain+    [ testGroup "Simple"+        [ testModelMatch "id"      id+        -- , testModelMatch "never1"  never1+        , testModelMatch "fmap1"   fmap1+        , testModelMatch "filter1" filter1+        , testModelMatch "filter2" filter2+        , testModelMatch "accumE1" accumE1+        ]+    , testGroup "Complex"+        [ testModelMatch "counter"    counter+        , testModelMatch "double"     double+        , testModelMatch "sharing"    sharing+        , testModelMatch "recursive1" recursive1+        , testModelMatch "recursive2" recursive2+        , testModelMatch "recursive3" recursive3+        , testModelMatch "accumBvsE"  accumBvsE+        ]+    , testGroup "Dynamic Event Switching"+        [ testModelMatch  "observeE_id"         observeE_id+        , testModelMatchM "initialB_immediate"  initialB_immediate+        , testModelMatchM "initialB_recursive1" initialB_recursive1+        , testModelMatchM "initialB_recursive2" initialB_recursive2+        , testModelMatchM "dynamic_apply"       dynamic_apply+        , testModelMatchM "switchE1"            switchE1+        , testModelMatchM "switchB_two"         switchB_two+        ]+    -- TODO:+    --  * algebraic laws+    --  * larger examples+    --  * quickcheck+    ]++{-----------------------------------------------------------------------------+    Testing+------------------------------------------------------------------------------}+matchesModel+    :: (Show b, Eq b)+    => (Event a -> Moment (Event b)) -> [a] -> IO Bool+matchesModel f xs = do+    bs1 <- return $ interpretModel f (singletons xs)+    bs2 <- interpretGraph f (singletons xs)+    -- bs3 <- interpretFrameworks f xs+    let bs = [bs1,bs2]+    let b = all (==bs1) bs+    when (not b) $ mapM_ print bs+    return b++singletons = map Just++-- test whether model matches+testModelMatchM+    :: (Show b, Eq b)+    => String -> (Event Int -> Moment (Event b)) -> Test+testModelMatchM name f = testCase name $ assert $ matchesModel f [1..8::Int]+testModelMatch name f = testModelMatchM name (return . f)++-- individual tests for debugging+testModel :: (Event Int -> Event b) -> [Maybe b]+testModel f = interpretModel (return . f) $ singletons [1..8::Int]+testGraph f = interpretGraph (return . f) $ singletons [1..8::Int]++testModelM f = interpretModel f $ singletons [1..8::Int]+testGraphM f = interpretGraph f $ singletons [1..8::Int]+++{-----------------------------------------------------------------------------+    Tests+------------------------------------------------------------------------------}+never1 :: Event Int -> Event Int+never1    = const never+fmap1     = fmap (+1)++filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing)+filter1   = filterE (>= 3)+filter2   = filterE (>= 3) . fmap (subtract 1)+accumE1   = accumE 0 . ((+1) <$)++counter e = applyE (pure const <*> bcounter) e+    where bcounter = accumB 0 $ fmap (\_ -> (+1)) e++merge e1 e2 = unionWith (++) (list e1) (list e2)+    where list = fmap (:[])+    +double e  = merge e e+sharing e = merge e1 e1+    where e1 = filterE (< 3) e+recursive1 e1 = e2+    where+    e2 = applyE b e1+    b  = (+) <$> stepperB 0 e2+recursive2 e1 = e2+    where+    e2 = applyE b e1+    b  = (+) <$> stepperB 0 e3+    e3 = applyE (id <$> b) e1   -- actually equal to e2++type Dummy = Int++-- counter that can be decreased as long as it's >= 0+recursive3 :: Event Dummy -> Event Int+recursive3 edec = applyE (const <$> bcounter) ecandecrease+    where+    bcounter     = accumB 4 $ (subtract 1) <$ ecandecrease+    ecandecrease = whenE ((>0) <$> bcounter) edec++-- test accumE vs accumB+accumBvsE :: Event Dummy -> Event [Int]+accumBvsE e = merge e1 e2+    where+    e1 = accumE 0 ((+1) <$ e)+    e2 = let b = accumB 0 ((+1) <$ e) in applyE (const <$> b) e+++observeE_id = observeE . fmap return -- = id++initialB_immediate e = do+    x <- initialB (stepper 0 e)+    return $ x <$ e+initialB_recursive1 e1 = mdo+    _ <- initialB b+    let b = stepper 0 e1+    return $ b <@ e1+    +-- NOTE: This test case tries to reproduce a situation+-- where the value of a latch is used before the latch was created.+-- This was relevant for the CRUD example, but I can't find a way+-- to make it smaller right now. Oh well.+initialB_recursive2 e1 = mdo+    x <- initialB b+    let bf = const x <$ stepper 0 e1 +    let b  = stepper 0 $ (bf <*> b) <@ e1+    return $ b <@ e1++dynamic_apply e = do+    mb <- trimB $ stepper 0 e+    return $ observeE $ (initialB =<< mb) <$ e+    -- = stepper 0 e <@ e+switchE1 e = do+    me <- trimE e+    return $ switchE $ me <$ e+switchB_two e = do+    mb0 <- trimB $ stepper 0 $ filterE even e+    mb1 <- trimB $ stepper 1 $ filterE odd  e+    b0  <- mb0+    let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e+    return $ b <@ e

@@ -0,0 +1,102 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+-- * Synopsis+-- | Merge model and implementation into a single type. Not pretty.++module Reactive.Banana.Test.Plumbing where++import Control.Applicative+import Control.Monad (liftM)+import Control.Monad.Fix++import qualified Reactive.Banana.Model as X+import qualified Reactive.Banana.Internal.EventBehavior1 as Y+import qualified Reactive.Banana.Internal.InputOutput as Y++{-----------------------------------------------------------------------------+    Types as pairs+------------------------------------------------------------------------------}++data Event    a = E (X.Event    a) (Y.Event    a)+data Behavior a = B (X.Behavior a) (Y.Behavior a)+data Moment   a = M (X.Moment   a) (Y.Moment   a)++-- pair extractions+fstE (E x _) = x; sndE (E _ y) = y+fstB (B x _) = x; sndB (B _ y) = y+fstM (M x _) = x; sndM (M _ y) = y++-- partial embedding functions+ex x = E x undefined; ey y = E undefined y+bx x = B x undefined; by y = B undefined y+mx x = M x undefined; my y = M undefined y++-- interpretation+interpretModel :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]+interpretModel f = X.interpret (fmap fstE . fstM . f . ex)++interpretGraph :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpretGraph f = Y.interpret (fmap sndE . sndM . f . ey)++{-----------------------------------------------------------------------------+    Primitive combinators+------------------------------------------------------------------------------}+never                           = E X.never Y.never+filterJust (E x y)              = E (X.filterJust x) (Y.filterJust y)+unionWith f (E x1 y1) (E x2 y2) = E (X.unionWith f x1 x2) (Y.unionWith f y1 y2)+mapE f (E x y)                  = E (X.mapE f x) (Y.mapE f y)+applyE ~(B x1 y1) (E x2 y2)     = E (X.applyE x1 x2) (Y.applyE y1 y2)+accumE a (E x y)                = E (X.accumE a x) (Y.accumE a y)++instance Functor Event where fmap = mapE++stepper = stepperB+stepperB a (E x y)              = B (X.stepperB a x) (Y.stepperB a y)+pureB a                         = B (X.pureB a) (Y.pureB a)+applyB (B x1 y1) (B x2 y2)      = B (X.applyB x1 x2) (Y.applyB y1 y2)+mapB f (B x y)                  = B (X.mapB f x) (Y.mapB f y)++instance Functor     Behavior where fmap = mapB+instance Applicative Behavior where pure = pureB; (<*>) = applyB++instance Functor Moment where fmap = liftM+instance Monad Moment where+    return a = M (return a) (return a)+    (M x y) >>= g = M (x >>= fstM . g) (y >>= sndM . g)+instance MonadFix Moment where+    mfix f = M (mfix fx) (mfix fy)+        where+        fx a = let M x _ = f a in x+        fy a = let M _ y = f a in y++trimE :: Event a -> Moment (Moment (Event a))+trimE (E x y) = M+    (fmap (fmap ex . mx) $ X.trimE x)+    (fmap (fmap ey . my) $ Y.trimE y)+trimB :: Behavior a -> Moment (Moment (Behavior a))+trimB (B x y) = M+    (fmap (fmap bx . mx) $ X.trimB x)+    (fmap (fmap by . my) $ Y.trimB y)++initialB ~(B x y) = M (X.initialB x) (Y.initialB y)++observeE :: Event (Moment a) -> Event a+observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y)++switchE :: Event (Moment (Event a)) -> Event a+switchE (E x y) = E+    (X.switchE $ X.mapE (fstM . fmap fstE) x)+    (Y.switchE $ Y.mapE (sndM . fmap sndE) y)++switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a+switchB (B x y) (E xe ye) = B+    (X.switchB x $ X.mapE (fstM . fmap fstB) xe)+    (Y.switchB y $ Y.mapE (sndM . fmap sndB) ye)++{-----------------------------------------------------------------------------+    Derived combinators+------------------------------------------------------------------------------}+accumB acc = stepperB acc . accumE acc+whenE b = filterJust . applyE ((\b e -> if b then Just e else Nothing) <$> b)+b <@ e = applyE (const <$> b) e

@@ -1,88 +0,0 @@-{------------------------------------------------------------------------------    Reactive Banana-    -    Test cases and examples-------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, NoMonomorphismRestriction #-}--module Reactive.Banana.Tests where--import Control.Monad (when)--import Reactive.Banana.Combinators-import Reactive.Banana.Frameworks (interpretFrameworks)---- import Test.QuickCheck--- import Test.QuickCheck.Property--{------------------------------------------------------------------------------    Testing-------------------------------------------------------------------------------}-matchesModel :: (Show b, Eq b)-             => (forall t. Event t a -> Event t b) -> [a] -> IO Bool-matchesModel f xs = do-    bs1 <- interpretModel      f (singletons xs)-    bs2 <- interpretPushGraph  f (singletons xs)-    bs3 <- interpretFrameworks f xs-    let bs = [bs1,bs2,bs3]-    let b = all (==bs1) bs-    when (not b) $ mapM_ print bs-    return b--testSuite = do-        -- trivial unit tests-        test id-        -- test never1-        test fmap1-        test filter1-        test filter2-        test counter-        test double-        test sharing-        test decrease-        test accumBvsE-        -- TODO:-        --  * algebraic laws-        --  * larger examples-        --  * quickcheck--test :: (Show b, Eq b) => (forall t. Event t Int -> Event t b) -> IO ()-test f = print =<< matchesModel f [1..8::Int]--singletons = map (\x -> [x])--{------------------------------------------------------------------------------    Examples-------------------------------------------------------------------------------}-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]--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-sharing e = union e1 e1-    where e1 = filterE (< 3) e--type Dummy = Int---- counter that can be decreased as long as it's >= 0-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 accumB-accumBvsE :: Event t Dummy -> Event t Int-accumBvsE input = e1 `union` e2-    where-    e  = input `union` input-    e1 = accumE 0 ((+1) <$ e)-    e2 = let b = accumB 0 ((+1) <$ e) in apply (const <$> b) e-