reactive-banana 0.5.0.3 → 0.6.0.0

raw patch · 10 files changed

+473/−283 lines, 10 filesdep ~containersdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, unordered-containers

API changes (from Hackage documentation)

Files

• reactive-banana.cabal +46/−24
• src/Reactive/Banana/Combinators.hs +87/−29
• src/Reactive/Banana/Frameworks.hs +87/−44
• src/Reactive/Banana/Internal/AST.hs +10/−17
• src/Reactive/Banana/Internal/CompileModel.hs +62/−0
• src/Reactive/Banana/Internal/InputOutput.hs +2/−22
• src/Reactive/Banana/Internal/InterpretModel.hs +75/−0
• src/Reactive/Banana/Internal/Model.hs +0/−141
• src/Reactive/Banana/Model.hs +94/−0
• src/Reactive/Banana/Tests.hs +10/−6

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             0.5.0.3+Version:             0.6.0.0 Synopsis:            Practical library for functional reactive programming (FRP). Description:              Reactive-banana is a practical library for Functional Reactive Programming (FRP).@@ -22,41 +22,63 @@ Stability:           Experimental Category:            FRP Cabal-version:       >=1.6-- Build-type:          Simple+ extra-source-files:  doc/examples/*.hs +Source-repository head+    type:               git+    location:           git://github.com/HeinrichApfelmus/reactive-banana.git+    subdir:             reactive-banana/++flag UseExtensions+    description: Use language extensions like type families or GADTs.+                 This enables the efficient push-driven implementation,+                 but doesn't necessarily work with compilers other than GHC.+-- Cabal checks if the package can be build with  UseExtensions = True,+-- otherewise it is set to  False .+ Library     hs-source-dirs:     src-    extensions:-                        TypeFamilies, FlexibleContexts,-                        FlexibleInstances, EmptyDataDecls,-                        GADTs, BangPatterns, TupleSections,-                        Rank2Types, NoMonomorphismRestriction,-                        DeriveDataTypeable-    build-depends:-        base >= 4.2 && < 5, containers >= 0.3 && < 0.5,-        transformers >= 0.2 && < 0.4,-        QuickCheck >= 1.2 && < 2.5,-        vault == 0.2.*, unordered-containers == 0.2.*, hashable == 1.1.*,-        fclabels == 1.1.*+    +    extensions:         CPP,+                        Rank2Types, NoMonomorphismRestriction, FlexibleInstances+    +    build-depends:      base >= 4.2 && < 5, containers >= 0.3 && < 0.6,+                        transformers >= 0.2 && < 0.4,+                        vault == 0.2.*+    +    if flag(UseExtensions)+        extensions:     TypeFamilies, GADTs, MultiParamTypeClasses,+                        BangPatterns, TupleSections,+                        EmptyDataDecls+        build-depends:  QuickCheck >= 1.2 && < 2.5,+                        fclabels == 1.1.*,+                        unordered-containers >= 0.2.1.0 && < 0.3,+                        hashable == 1.1.*+        CPP-options:    -DUseExtensions+             exposed-modules:                         Reactive.Banana,                         Reactive.Banana.Combinators,-                        Reactive.Banana.Frameworks,                         Reactive.Banana.Experimental.Calm,-                        Reactive.Banana.Internal.Model+                        Reactive.Banana.Frameworks,+                        Reactive.Banana.Model+         other-modules:-                        Reactive.Banana.Internal.AST,                         Reactive.Banana.Internal.InputOutput,-                        Reactive.Banana.Internal.PushGraph,-                        Reactive.Banana.Internal.TotalOrder,                         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 +                         -Source-repository head-    type:               git-    location:           git://github.com/HeinrichApfelmus/reactive-banana.git-    subdir:             reactive-banana/ 

@@ -1,7 +1,10 @@ {------------------------------------------------------------------------------    Reactive Banana+    reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, MultiParamTypeClasses, TupleSections, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- #define UseExtensions 1  module Reactive.Banana.Combinators (     -- * Synopsis@@ -16,7 +19,7 @@     -- * Core Combinators     module Control.Applicative,     module Data.Monoid,-    never, union, filterE, collect, spill, accumE,+    never, union, unions, filterE, collect, spill, accumE,     apply, stepper,     -- $classes     @@ -30,6 +33,9 @@     calm, unionWith,     -- ** Apply class     Apply(..),+    +    -- * Internal+    PrimEvent, PrimBehavior,     ) where  import Control.Applicative@@ -38,11 +44,30 @@ import Data.Maybe (isJust) 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 qualified Reactive.Banana.Internal.AST as AST-import qualified Reactive.Banana.Internal.Model as Model 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+++ {-----------------------------------------------------------------------------     Introduction ------------------------------------------------------------------------------}@@ -59,14 +84,14 @@  > type Event t a = [(Time,a)] -}-newtype Event t a = E { unE :: AST.Event AST.Expr [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 :: AST.Behavior AST.Expr a }+newtype Behavior t a = B { unB :: PrimBehavior a }     -- ^ (Constructor exported for internal use only.)  {-$intro2@@ -80,7 +105,7 @@ While the type synonyms mentioned above are the way you should think about 'Behavior' and 'Event', they are a bit vague for formal manipulation. To remedy this, the library provides a very simple but authoritative-model implementation. See 'Reactive.Banana.Model' for more.+model implementation. See "Reactive.Banana.Model" for more.  -} @@ -90,25 +115,31 @@ -- | Interpret with model implementation. -- Useful for testing. interpretModel :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]]-interpretModel f xs =-    map toList <$> Model.interpretModel (unE . f . E) (map Just xs)+interpretModel f xs = map toList <$> Prim.interpretModel (unE . f . E) (map Just xs) --- | Interpret with push-based implementation.+-- | 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 $ AST.inputE i)+    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  {------------------------------------------------------------------------------    Basic combinators--    Implemented in terms of Reactive.Banana.Internal.AST+    Core combinators ------------------------------------------------------------------------------} singleton :: a -> [a] singleton x = [x]@@ -116,7 +147,7 @@ -- | Event that never occurs. -- Think of it as @never = []@. never    :: Event t a-never = E $ singleton <$> AST.never+never = E $ Prim.mapE singleton Prim.never  -- | Merge two event streams of the same type. -- In case of simultaneous occurrences, the left argument comes first.@@ -126,14 +157,20 @@ -- >    | timex <= timey = (timex,x) : union xs ((timey,y):ys) -- >    | timex >  timey = (timey,y) : union ((timex,x):xs) ys union    :: Event t a -> Event t a -> Event t a-union e1 e2 = E $ AST.unionWith (++) (unE e1) (unE e2)+union e1 e2 = E $ Prim.unionWith (++) (unE e1) (unE e2) +-- | Merge several event streams of the same type.+-- +-- > unions = foldr union never+unions :: [Event t a] -> Event t a+unions = foldr union never+ -- | Allow all events that fulfill the predicate, discard the rest. -- Think of it as --  -- > filterE p es = [(time,a) | (time,a) <- es, p a] filterE   :: (a -> Bool) -> Event t a -> Event t a-filterE p = E . AST.filterE (not . null) . (filter p <$>) . unE+filterE p = E . Prim.filterE (not . null) . (Prim.mapE (filter p)) . unE  -- | Collect simultaneous event occurences. -- The result will never contain an empty list.@@ -141,7 +178,7 @@ -- -- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])] collect   :: Event t a -> Event t [a]-collect e = E $ singleton <$> unE e+collect e = E $ Prim.mapE singleton (unE e)  -- | Emit simultaneous event occurrences. -- The first element in the list will be emitted first, and so on.@@ -150,7 +187,7 @@ -- -- > spill . collect = id spill :: Event t [a] -> Event t a-spill e = E $ concat <$> unE e+spill e = E $ Prim.mapE concat (unE e)  -- | Construct a time-varying function from an initial value and  -- a stream of new values. Think of it as@@ -164,7 +201,7 @@ -- Also note that in the case of simultaneous occurrences, -- only the last one is kept. stepper :: a -> Event t a -> Behavior t a-stepper x e = B $ AST.stepperB x (last <$> unE e)+stepper x e = B $ Prim.stepperB x $ Prim.mapE last $ unE e  -- | The 'accumE' function accumulates a stream of events. -- Example:@@ -175,14 +212,15 @@ -- Note that the output events are simultaneous with the input events, -- there is no \"delay\" like in the case of 'accumB'. accumE   :: a -> Event t (a -> a) -> Event t a-accumE acc = E . mapAccumE acc . fmap concatenate . unE+accumE acc = E . mapAccumE acc . Prim.mapE concatenate . unE     where     concatenate :: [a -> a] -> a -> ([a],a)     concatenate fs acc = (tail values, last values)         where values = scanl' (flip ($)) acc fs -    mapAccumE :: s -> AST.Event AST.Expr (s -> (a,s)) -> AST.Event AST.Expr a-    mapAccumE acc = fmap fst . AST.accumE (undefined,acc) . fmap (. snd)+    mapAccumE :: s -> PrimEvent (s -> (a,s)) -> PrimEvent a+    mapAccumE acc =+        Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd)  -- strict version of scanl scanl' :: (a -> b -> a) -> a -> [b] -> [a]@@ -195,7 +233,7 @@ --  -- > apply bf ex = [(time, bf time x) | (time, x) <- ex] apply    :: Behavior t (a -> b) -> Event t a -> Event t b-apply bf ex = E $ AST.applyE (map <$> unB bf) (unE ex)+apply bf ex = E $ Prim.applyE (Prim.mapB map $ unB bf) (unE ex)  {-$classes @@ -224,16 +262,19 @@  -} +{- No monoid instance, sorry.+ instance Monoid (Event t (a -> a)) where     mempty  = never     mappend = unionWith (flip (.))+-}  instance Functor (Event t) where-    fmap f e = E $ (map f) <$> (unE e)+    fmap f e = E $ Prim.mapE (map f) (unE e)  instance Applicative (Behavior t) where-    pure x = B $ AST.pureB x-    bf <*> bx = B $ AST.applyB (unB bf) (unB bx)+    pure x    = B $ Prim.pureB x+    bf <*> bx = B $ Prim.applyB (unB bf) (unB bx)  instance Functor (Behavior t) where     fmap = liftA@@ -241,6 +282,21 @@ {-----------------------------------------------------------------------------     Derived Combinators ------------------------------------------------------------------------------}+{-++Unfortunately, we can't make a  Num  instance because that would+require  Eq  and  Show .++instance Num a => Num (Behavior t a) where+    (+) = liftA2 (+)+    (-) = liftA2 (-)+    (*) = liftA2 (*)+    negate = fmap negate+    abs    = fmap abs+    signum = fmap signum+    fromInteger = pure . fromInteger+-}+ -- | Keep only the 'Just' values. -- Variant of 'filterE'. filterJust :: Event t (Maybe a) -> Event t a@@ -258,6 +314,8 @@ whenE bf = filterApply (const <$> bf)  -- | Split event occurrences according to a tag.+-- The 'Left' values go into the left component while the 'Right' values+-- go into the right component of the result. split :: Event t (Either a b) -> (Event t a, Event t b) split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e)     where@@ -271,7 +329,7 @@ -- -- > unionWith f e1 e2 = fmap (foldr1 f) <$> collect (e1 `union` e2) unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a-unionWith f e1 e2 = E $ AST.unionWith g (unE e1) (unE e2)+unionWith f e1 e2 = E $ Prim.unionWith g (unE e1) (unE e2)     where g xs ys = singleton $ foldr1 f (xs ++ ys)  -- | Keep only the last occurrence when simultaneous occurrences happen.

@@ -1,14 +1,15 @@ {------------------------------------------------------------------------------    Reactive Banana+    reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}+{-# LANGUAGE CPP, Rank2Types #-}+-- #define UseExtensions 1  module Reactive.Banana.Frameworks (     -- * Synopsis     -- | Build event networks using existing event-based frameworks and run them.          -- * Simple use-    interpret, interpretAsHandler,+    interpretAsHandler,      -- * Building event networks with input/output     -- $build@@ -23,36 +24,69 @@     -- * Utilities     -- $utilities     newAddHandler, newEvent,+    +    -- * Internal+    interpretFrameworks,     ) where  import Control.Applicative-import Control.Arrow (second)-import Control.Concurrent+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.Dynamic (Typeable) import Data.IORef-import Data.List (nub) import Data.Monoid--import qualified Data.HashMap.Strict as Map+import qualified Data.Unique -- ordinary uniques here, because they are Ord  import Reactive.Banana.Internal.InputOutput import Reactive.Banana.Combinators-import qualified Reactive.Banana.Internal.AST as AST++#if UseExtensions++import qualified Reactive.Banana.Internal.AST as Prim import qualified Reactive.Banana.Internal.PushGraph as Implementation -type Map = Map.HashMap+#else +import qualified Reactive.Banana.Model as Prim+import Reactive.Banana.Internal.CompileModel++#endif++import qualified Data.Map as Map++type Map = Map.Map+ {------------------------------------------------------------------------------    AST specific functions+    Compilation specific to the different backends ------------------------------------------------------------------------------}-inputE :: InputChannel [a] -> Event t a-inputE = E . AST.inputE+#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++-- types are imported by CompileModel++primChanges ~(Prim.StepperB x e) = e+primInitial ~(Prim.StepperB x e) = x++#endif+ {-----------------------------------------------------------------------------     NetworkDescription, setting up event networks ------------------------------------------------------------------------------}@@ -63,7 +97,7 @@     like @wxHaskell@ or @Gtk2Hs@.     How do you do that? -    This "Reactive.Banana.Implementation" module allows you to obtain /input/ events+    The module presented here allows you to obtain /input/ events     from external sources     and it allows you perform /output/ in reaction to events.     @@ -137,8 +171,9 @@ -- values of types 'Event' or 'Behavior' -- outside the 'NetworkDescription' monad. newtype NetworkDescription t a-    = Prepare { unPrepare :: RWST () (Preparations t) () IO 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@@ -192,12 +227,20 @@ -- this will register a callback function such that -- an event will occur whenever the callback function is called. fromAddHandler :: AddHandler a -> NetworkDescription t (Event t a)-fromAddHandler addHandler = Prepare $ do-    i <- liftIO $ newInputChannel+fromAddHandler addHandler = do+    (i,e) <- newInput     let addHandler' k = addHandler $ k . toValue i . (\x -> [x])-    tell ([],[addHandler'],[],[])-    return $ inputE i+    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)++ -- | Input, -- obtain a 'Behavior' by frequently polling mutable data, like the current time. --@@ -211,12 +254,12 @@ -- it should not perform expensive computations. -- Neither should its side effects affect the event network significantly. fromPoll :: IO a -> NetworkDescription t (Behavior t a)-fromPoll poll = Prepare $ do-    i <- liftIO $ newInputChannel+fromPoll poll = do+    (i,e) <- newInput     let poll' = toValue i . (:[]) <$> poll-    tell ([],[],[poll'],[])+    Prepare $ tell ([],[],[poll'],[])     initial <- liftIO $ poll-    return $ stepper initial (inputE i)+    return $ stepper initial e  -- | Input, -- obtain a 'Behavior' from an 'AddHandler' that notifies changes.@@ -238,7 +281,7 @@ -- -- > changes (stepper x e) = return (calm e) changes :: Behavior t a -> NetworkDescription t (Event t a)-changes ~(B (AST.Pair _ (AST.Stepper x e))) = return $ E $ fmap (:[]) e+changes = return . E . Prim.mapE (:[]) . primChanges . unB  -- | Output, -- observe the initial value contained in a 'Behavior'.@@ -246,7 +289,7 @@ -- Similar to 'updates', this function is not well-defined, -- but exists for reasons of efficiency. initial :: Behavior t a -> NetworkDescription t a-initial ~(B (AST.Pair _ (AST.Stepper x e))) = return x+initial = return . primInitial . unB  -- | Lift an 'IO' action into the 'NetworkDescription' monad, -- but defer its execution until compilation time.@@ -257,24 +300,24 @@ -- | Compile a 'NetworkDescription' into an 'EventNetwork' -- that you can 'actuate', 'pause' and so on. compile :: (forall t. NetworkDescription t ()) -> IO EventNetwork-compile (Prepare m) = do-    -- execute the NetworkDescription monad-    (_,_,(outputs,inputs,polls,liftIOs)) <- runRWST m () ()-    sequence_ liftIOs-    -    let -- union of all  reactimates-        E graph = foldr union never outputs-    -    automaton <- Implementation.compileToAutomaton graph-    +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 graph on a single input value+    let -- run the automaton on a single input value         run :: InputValue -> IO ()         run input = do-            -- takeMVar  makes sure that event graph updates are sequential.+            -- takeMVar  makes sure that event graph updates are atomic             automaton  <- takeMVar rautomaton             -- poll mutable data             pollValues <- sequence polls@@ -318,7 +361,7 @@     -- The network will /not/ stop immediately though, only after     -- the current event has been processed completely.     pause :: IO ()-    } deriving (Typeable)+    }  -- Make an event network from a function that registers all event handlers makeEventNetwork :: IO (IO ()) -> IO EventNetwork@@ -334,10 +377,10 @@ {-----------------------------------------------------------------------------     Simple use ------------------------------------------------------------------------------}--- | Simple way to run an event graph. Very useful for testing.--- Uses the efficient push-driven implementation.-interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]]-interpret f xs = do+-- | Interpret by using a framework internally.+-- Only useful for testing library internals.+interpretFrameworks :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]]+interpretFrameworks f xs = do     output                    <- newIORef []     (addHandler, runHandlers) <- newAddHandler     network                   <- compile $ do@@ -383,7 +426,7 @@ newAddHandler = do     handlers <- newIORef Map.empty     let addHandler k = do-            key <- newUnique+            key <- Data.Unique.newUnique             modifyIORef handlers $ Map.insert key k             return $ modifyIORef handlers $ Map.delete key         runHandlers x =

@@ -1,5 +1,5 @@ {------------------------------------------------------------------------------    Reactive-Banana+    reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE GADTs, TypeFamilies, TupleSections, EmptyDataDecls,     TypeSynonymInstances, FlexibleInstances #-}@@ -11,8 +11,10 @@ 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  {-----------------------------------------------------------------------------@@ -31,7 +33,7 @@     AccumE    :: a -> Event t (a -> a) -> EventD t a          InputE    :: InputChannel a   -> EventD t a   -- represent external inputs-    InputPure :: InputChannel (EventModel a)+    InputPure :: InputChannel (Model.Event a)               -> EventD t a                       -- input for model implementation  -- | Constructors for behaviors.@@ -116,7 +118,10 @@ 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@@ -128,12 +133,7 @@     changeR x (f,_) = (f,x) applyB _ _ = error "TODO: Don't know what to do with external behaviors." --- instance Functor (Event Expr) where-instance Functor (Pair Node (EventD Expr)) where-    fmap   = mapE--- instance Functor (Behavior Expr) where-instance Functor (Pair Node (BehaviorD Expr)) where-    fmap f = applyB (pureB f)+mapB f = applyB (pureB f)  {-----------------------------------------------------------------------------     The 'Node' type is used for observable sharing and must be defined here.@@ -150,21 +150,14 @@     , keyFormula :: !(Vault.Key (FormulaD Nodes a))     , keyOrder   :: !Unique       -- use for Reactive.Banana.Internal.Model-    , keyModelE  :: !(Vault.Key (EventModel a))-    , keyModelB  :: !(Vault.Key (BehaviorModel a))+    , 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.Model-------------------------------------------------------------------------------}--- we have to define the interpretation types here-type EventModel a    = [Maybe a]-data BehaviorModel a = StepperB a (EventModel a)  {-----------------------------------------------------------------------------     Reactive.Banana.Internal.PushGraph

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

@@ -16,38 +16,18 @@     -- | Stepwise execution of an event graph.     Automaton(..), fromStateful, unfoldAutomaton, -    -- * Uniques-    -- | Doesn't belong here, but we also have some stuff about uniques-    -- that we use for observable sharing.-    Unique, newUnique,     ) where  import Control.Applicative import Control.Exception (evaluate) -import qualified Data.Unique as Unique+import Data.Unique.Really import qualified Data.Vault  as Vault-import Data.Hashable-import System.Mem.StableName  {------------------------------------------------------------------------------    Better Uniques-------------------------------------------------------------------------------}-type ReallyUnique = StableName Unique.Unique-type Unique = ReallyUnique---- instance Hashable Unique--newUnique :: IO Unique-newUnique = do-    x <- Unique.newUnique-    evaluate x-    makeStableName x--{-----------------------------------------------------------------------------     Storing heterogenous input values ------------------------------------------------------------------------------}-type Channel  = ReallyUnique    -- identifies an input+type Channel  = Unique          -- identifies an input type Key      = Vault.Key       -- key to retrieve a value type Value    = Vault.Vault     -- value storage 

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

@@ -1,141 +0,0 @@-{------------------------------------------------------------------------------    Reactive-Banana-------------------------------------------------------------------------------}-{-# LANGUAGE GADTs #-}-module Reactive.Banana.Internal.Model (-    -- * Synopsis-    -- | Model implementation of the abstract syntax tree.-    -    -- * Description-    -- $model--    -- Combinators-    -- Event(..), Behavior(..),-    -- never, filterE, unionWith, applyE, accumE, stepper,-   -    -- * Interpretation-    interpretModel,-    ) where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Trans.State-import qualified Data.Vault as Vault--import qualified Reactive.Banana.Internal.AST as AST-import Reactive.Banana.Internal.InputOutput--{-$model--This module contains the model implementation for the primitive combinators-defined "Reactive.Banana.Internal.AST"-which in turn are the basis for the official combinators-documented in "Reactive.Banana.Combinators".--This module does not export any combinators,-you have to look at the source code to make use of it.-(If there is no link to the source code at every type signature,-then you have to run cabal with --hyperlink-source flag.)--This model is /authoritative/: when observed with the 'interpretModel' function,-both the actual implementation and its model /must/ agree on the result.-Note that this must also hold for recursive and partial definitions-(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).--Concerning time and space complexity, the model is not authoritative, however.-Implementations are free to be much more efficient.--}--{------------------------------------------------------------------------------    Combinators-------------------------------------------------------------------------------}--- due to observable sharing, the types have to be imported from--- the module Reactive.Banana.Internal.AST-type Event a    = AST.EventModel a     -- = [Maybe a]-type Behavior a = AST.BehaviorModel a  -- = StepperB a (Event a)--never :: Event a-never = repeat Nothing--filterE :: (a -> Bool) -> Event a -> Event a-filterE p = map (>>= \x -> if p x then Just x else Nothing)--unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f = zipWith g-    where-    g (Just x) (Just y) = Just $ f x y-    g (Just x) Nothing  = Just x-    g Nothing  (Just y) = Just y-    g Nothing  Nothing  = Nothing--applyE :: Behavior (a -> b) -> Event a -> Event b-applyE _                   []     = []-applyE (AST.StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs-    where-    step a (Nothing:b) = stepper a b-    step _ (Just a :b) = stepper a b--accumE :: a -> Event (a -> a) -> Event a-accumE x []           = []-accumE x (Nothing:fs) = Nothing : accumE x fs-accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) --stepper :: a -> [Maybe a] -> Behavior a-stepper = AST.StepperB--{------------------------------------------------------------------------------    Interpretation, pays attention to observable sharing-------------------------------------------------------------------------------}--- state monad for evaluation-type Eval = State Vault.Vault---- | Interpret an event graph with the model implementation.--- Mainly useful for testing library internals.-interpretModel-    :: (AST.Event AST.Expr a -> AST.Event AST.Expr b)-    -> Event a -> IO (Event b)-interpretModel f input = do-    i0 <- newInputChannel-    -    let-        evalE :: AST.EventD AST.Expr a -> Eval (Event a)-        evalE (AST.Never)             = return $ never-        evalE (AST.UnionWith f e1 e2) = unionWith f <$> goE e1 <*> goE e2-        evalE (AST.FilterE p e)       = filterE p   <$> goE e-        evalE (AST.ApplyE b e )       = applyE      <$> goB b  <*> goE e-        evalE (AST.AccumE x e )       = accumE x    <$> goE e-        evalE (AST.InputPure i)       =-            return $ maybe err id $ fromValue i (toValue i0 input)-            where err = error "Reactive.Banana.PushIO.interpretModel: internal error: Input"-        evalE _                       =-            error "Reactive.Banana.PushIO.interpretModel: internal error: E"--        evalB :: AST.BehaviorD AST.Expr a -> Eval (Behavior a)-        evalB (AST.Stepper x e) = stepper x <$> goE e-        evalB _                 =-            error "Reactive.Banana.PushIO.interpretModel: internal error: B"--        goE :: AST.Event AST.Expr a -> Eval (Event a)-        goE (AST.Pair node e) = do-            values <- get-            case Vault.lookup (AST.keyModelE node) values of-                Nothing -> mfix $ \v -> do-                    modify $ Vault.insert (AST.keyModelE node) v-                    evalE e-                Just v  -> return v--        goB :: AST.Behavior AST.Expr a -> Eval (Behavior a)-        goB (AST.Pair node b) = do-            values <- get-            case Vault.lookup (AST.keyModelB node) values of-                Nothing -> mfix $ \v -> do-                    modify $ Vault.insert (AST.keyModelB node) v-                    evalB b-                Just v  -> return v-    -    return $-        zipWith const-            (evalState (goE $ f $ AST.inputPure i0) Vault.empty)-            input-

@@ -0,0 +1,94 @@+{-----------------------------------------------------------------------------+    reactive-banana+------------------------------------------------------------------------------}+module Reactive.Banana.Model (+    -- * Synopsis+    -- | Model implementation of the abstract syntax tree.+    +    -- * Description+    -- $model++    -- * Combinators+    Event(..), Behavior(..),+    never, filterE, unionWith, applyE, accumE, stepperB,+    mapE, pureB, applyB, mapB,+    +    -- * Interpretation+    interpretModel,+    ) where++import Control.Applicative++{-$model++This module contains the model implementation for the primitive combinators+defined "Reactive.Banana.Internal.AST"+which in turn are the basis for the official combinators+documented in "Reactive.Banana.Combinators".++Look at the source code to make maximal use of this module.+(If there is no link to the source code at every type signature,+then you have to run cabal with --hyperlink-source flag.)++This model is /authoritative/: when observed with the 'interpretModel' function,+both the actual implementation and its model /must/ agree on the result.+Note that this must also hold for recursive and partial definitions+(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).++Concerning time and space complexity, the model is not authoritative, however.+Implementations are free to be much more efficient.+-}++{-----------------------------------------------------------------------------+    Combinators+------------------------------------------------------------------------------}+type Event a    = [Maybe a]+data Behavior a = StepperB a (Event a)++never :: Event a+never = repeat Nothing++filterE :: (a -> Bool) -> Event a -> Event a+filterE p = map (>>= \x -> if p x then Just x else Nothing)++unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a+unionWith f = zipWith g+    where+    g (Just x) (Just y) = Just $ f x y+    g (Just x) Nothing  = Just x+    g Nothing  (Just y) = Just y+    g Nothing  Nothing  = Nothing++applyE :: Behavior (a -> b) -> Event a -> Event b+applyE _               []     = []+applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs+    where+    step a (Nothing:b) = stepperB a b+    step _ (Just a :b) = stepperB a b++accumE :: a -> Event (a -> a) -> Event a+accumE x []           = []+accumE x (Nothing:fs) = Nothing : accumE x fs+accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) ++stepperB :: a -> [Maybe a] -> Behavior a+stepperB = StepperB++-- functor+mapE f  = applyE (pureB f)++-- applicative functor+pureB x = stepperB x never++applyB :: Behavior (a -> b) -> Behavior a -> Behavior b+applyB (StepperB f fe) (StepperB x xe) =+    stepperB (f x) $ mapE (uncurry ($)) pair+    where+    pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe)+    changeL f (_,x) = (f,x)+    changeR x (f,_) = (f,x)++mapB f = applyB (pureB f)++interpretModel :: (Event a -> Event b) -> Event a -> IO (Event b)+interpretModel = (return .)

@@ -10,6 +10,7 @@ import Control.Monad (when)  import Reactive.Banana.Combinators+import Reactive.Banana.Frameworks (interpretFrameworks)  -- import Test.QuickCheck -- import Test.QuickCheck.Property@@ -18,12 +19,15 @@     Testing ------------------------------------------------------------------------------} matchesModel :: (Show b, Eq b)-             => (forall t. Event t a -> Event t b) -> [[a]] -> IO Bool+             => (forall t. Event t a -> Event t b) -> [a] -> IO Bool matchesModel f xs = do-    bs1 <- interpretModel     f xs-    bs2 <- interpretPushGraph f xs-    when (bs1 /= bs2) $ print bs1 >> print bs2-    return $ bs1 == bs2+    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@@ -43,7 +47,7 @@         --  * quickcheck  test :: (Show b, Eq b) => (forall t. Event t Int -> Event t b) -> IO ()-test f = print =<< matchesModel f (singletons [1..8::Int])+test f = print =<< matchesModel f [1..8::Int]  singletons = map (\x -> [x])