reactive-banana 1.0.0.1 → 1.1.0.0

raw patch · 9 files changed

+191/−191 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• reactive-banana.cabal +1/−1
• src/Reactive/Banana/Combinators.hs +28/−12
• src/Reactive/Banana/Frameworks.hs +20/−26
• src/Reactive/Banana/Internal/Combinators.hs +14/−12
• src/Reactive/Banana/Model.hs +103/−120
• src/Reactive/Banana/Prim/Types.hs +0/−2
• src/Reactive/Banana/Test.hs +3/−3
• src/Reactive/Banana/Test/Plumbing.hs +15/−15

@@ -1,6 +1,13 @@ Changelog for the `reactive-banana` package ------------------------------------------- +**version 1.1.0.0**++* Fix bug: Types of `switchB` and `switchE` need to be in the `Moment` monad.+* Clean up and simplify model implementation in the `Reactive.Banana.Model` module.+* Update type signatures of the `interpret*` functions to make it easier to try FRP functions in the REPL.+* Remove `showNetwork` function.+ **version 1.0.0.1**  * Improve documentation.

@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             1.0.0.1+Version:             1.1.0.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).

@@ -72,14 +72,32 @@ ------------------------------------------------------------------------------} -- | Interpret an event processing function. -- Useful for testing.-interpret :: (Event a -> Event b) -> [Maybe a] -> IO [Maybe b]-interpret f = Prim.interpret (return . unE . f . E)+--+-- Note: You can safely assume that this function is pure,+-- even though the type seems to suggest otherwise.+-- I'm really sorry about the extra 'IO', but it can't be helped.+-- See source code for the sordid details.+interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]+interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs+-- FIXME: I would love to remove the 'IO' from the type signature,+-- but unfortunately, it is possible that the argument to interpret+-- returns an Event that was created in the context of an existing network, e.g.+--+-- >   eBad <- fromAddHandler ...+-- >   ...+-- >   let ys = interpret (\_ -> return eBad ) xs+--+-- Doing this is a big no-no and will break a lot of things,+-- but if we remove the 'IO' here, then we will also break referential+-- transparency, and I think that takes it too far.  {-----------------------------------------------------------------------------     Core combinators ------------------------------------------------------------------------------} -- | Event that never occurs.--- Semantically, @never = []@.+-- Semantically,+--+-- > never = [] never    :: Event a never = E Prim.never @@ -240,22 +258,20 @@ -- | Dynamically switch between 'Event'. -- Semantically, ----- > switchE ee = concat [trim t1 t2 e | (t1,t2,e) <- intervals ee]+-- > switchE ee = \time0 -> concat [trim t1 t2 e | (t1,t2,e) <- intervals ee, time0 <= t1] -- >     where -- >     intervals e        = [(time1, time2, x) | ((time1,x),(time2,_)) <- zip e (tail e)] -- >     trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2]--switchE :: Event (Event a) -> Event a-switchE = E . Prim.switchE . Prim.mapE (unE) . unE+switchE :: MonadMoment m => Event (Event a) -> m (Event a)+switchE = liftMoment . M . fmap E . Prim.switchE . Prim.mapE (unE) . unE  -- | Dynamically switch between 'Behavior'. -- Semantically, ----- >  switchB b0 eb = \time ->--- >     last (b0 : [b | (time2,b) <- eb, time2 < time]) time--switchB :: Behavior a -> Event (Behavior a) -> Behavior a-switchB b = B . Prim.switchB (unB b) . Prim.mapE (unB) . unE+-- >  switchB b0 eb = \time0 -> \time1 ->+-- >     last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1+switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a)+switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE (unB) . unE  {-----------------------------------------------------------------------------     Derived Combinators

@@ -30,13 +30,11 @@     -- ** Utility functions     -- | This section collects a few convience functions     -- built from the core functions.-    newEvent, mapEventIO, newBehavior,+    interpretFrameworks, newEvent, mapEventIO, newBehavior,      -- * Running event networks     EventNetwork, actuate, pause, -    -- * Internal-    interpretFrameworks, showNetwork,     ) where  import           Control.Event.Handler@@ -320,16 +318,6 @@ pause :: EventNetwork -> IO () pause   = Prim.pause . unEN --- | A multiline description of the current 'Latch'es and 'Pulse's in--- the 'EventNetwork'.------ Incidentally, evaluation the returned string to normal--- form will also force the 'EventNetwork' to some kind of normal form.--- This may be useful for benchmarking purposes.-showNetwork :: EventNetwork -> IO String-showNetwork = Prim.showNetwork . unEN-- {-----------------------------------------------------------------------------     Utilities ------------------------------------------------------------------------------}@@ -381,30 +369,36 @@ {-----------------------------------------------------------------------------     Simple use ------------------------------------------------------------------------------}--- | Interpret by using a framework internally.--- Only useful for testing library internals.-interpretFrameworks :: (Event a -> Event b) -> [a] -> IO [[b]]+-- | Interpret an event processing function by building an 'EventNetwork'+-- and running it. Useful for testing, but uses 'MomentIO'.+-- See 'interpret' for a plain variant.+interpretFrameworks :: (Event a -> MomentIO (Event b)) -> [Maybe a] -> IO [Maybe b] interpretFrameworks f xs = do-    output                    <- newIORef []+    output                    <- newIORef Nothing     (addHandler, runHandlers) <- newAddHandler     network                   <- compile $ do-        e <- fromAddHandler addHandler-        reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e)+        e1 <- fromAddHandler addHandler+        e2 <- f e1+        reactimate $ writeIORef output . Just <$> e2      actuate network     bs <- forM xs $ \x -> do-        runHandlers x-        bs <- readIORef output-        writeIORef output []-        return bs+        case x of+            Nothing -> return Nothing+            Just x  -> do+                runHandlers x+                b <- readIORef output+                writeIORef output Nothing+                return b     return bs  -- | Simple way to write a single event handler with -- functional reactive programming.-interpretAsHandler :: (Event a -> Event b) -> AddHandler a -> AddHandler b+interpretAsHandler :: (Event a -> Moment (Event b)) -> AddHandler a -> AddHandler b interpretAsHandler f addHandlerA = AddHandler $ \handlerB -> do     network <- compile $ do-        e <- fromAddHandler addHandlerA-        reactimate $ handlerB <$> f e+        e1 <- fromAddHandler addHandlerA+        e2 <- liftMoment (f e1)+        reactimate $ handlerB <$> e2     actuate network     return (pause network)

@@ -49,7 +49,6 @@     { runStep :: Prim.Step -> IO ()     , actuate :: IO ()     , pause   :: IO ()-    , showNetwork :: IO String     }  -- | Compile to an event network.@@ -70,7 +69,6 @@             { runStep = runStep             , actuate = writeIORef actuated True             , pause   = writeIORef actuated False-            , showNetwork = show <$> readMVar s             }      (output, s0) <-                             -- compile initial graph@@ -195,18 +193,22 @@     p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e     return $ fromPure p -switchE :: Event (Event a) -> Event a-switchE = liftCached1 $ \p1 -> do-    p2 <- liftBuild $ Prim.mapP (runCached) p1-    p3 <- executeP p2-    liftBuild $ Prim.switchP p3+switchE :: Event (Event a) -> Moment (Event a)+switchE e = ask >>= \r -> cacheAndSchedule $ do+    p1 <- runCached e+    liftBuild $ do+        p2 <- Prim.mapP (runReaderT . runCached) p1+        p3 <- Prim.executeP p2 r+        Prim.switchP p3 -switchB :: Behavior a -> Event (Behavior a) -> Behavior a-switchB = liftCached2 $ \(l0,p0) p1 -> do-    p2 <- liftBuild $ Prim.mapP (runCached) p1-    p3 <- executeP p2-    +switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB b e = ask >>= \r -> cacheAndSchedule $ do+    ~(l0,p0) <- runCached b+    p1       <- runCached e     liftBuild $ do+        p2 <- Prim.mapP (runReaderT . runCached) p1+        p3 <- Prim.executeP p2 r+         lr <- Prim.switchL l0 =<< Prim.mapP fst p3         -- TODO: switch away the initial behavior         let c1 = p0                              -- initial behavior changes

@@ -1,32 +1,33 @@ {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Model (     -- * Synopsis     -- | Model implementation for learning and testing.      -- * Overview-    -- $model--    -- * Combinators-    -- ** Data types-    Time, Event, Behavior, Moment,-    -- ** Basic-    never, filterJust, unionWith, mapE, accumE, applyE,-    stepperB, pureB, applyB, mapB,-    -- ** Dynamic event switching-    valueB, observeE, switchE, switchB,+    -- $overview -    -- * Interpretation+    -- * Core Combinators+    -- ** Event and Behavior+    Nat, Time,+    Event(..), Behavior(..),     interpret,+    -- ** First-order+    module Control.Applicative,+    never, unionWith, filterJust, apply,+    -- ** Moment and accumulation+    Moment(..), accumE, stepper,+    -- ** Higher-order+    valueB, observeE, switchE, switchB,     ) where  import Control.Applicative-import Control.Monad (join)-import Data.List     (splitAt)+import Control.Monad+import Control.Monad.Fix -{-$model+{-$overview  This module reimplements the key FRP types and functions from the module "Reactive.Banana.Combinators" in a way that is hopefully easier to understand.@@ -37,151 +38,133 @@ (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+This model is /authoritative/:+Event functions that have been constructed using the same combinators+/must/ give the same results when run with the @interpret@ function+from either the module "Reactive.Banana.Combinators"+or the module "Reactive.Banana.Model".+This must also hold for recursive and partial definitions (at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).  -}  {------------------------------------------------------------------------------    Types+    Event and Behavior ------------------------------------------------------------------------------}+-- | Natural numbers (poorly represented).+type Nat = Int+ -- | The FRP model used in this library is actually a model with continuous time. -- -- However, it can be shown that this model is observationally -- equivalent to a particular model with (seemingly) discrete time steps, -- which is implemented here.+-- The main reason for doing this is to be able to handle recursion correctly. -- Details will be explained elsewhere.-type Time = Int--data Event    a = E Time [Maybe a]  -- starting time, event values (always infinite)-    deriving (Show)-data Behavior a = B Time a [a]      -- starting time, old value, new values (always infinite)-    deriving (Show)-type Moment   a = Time -> a         -- should be abstract--epoch :: Time-epoch = 0+type Time = Nat -- begins at t = 0 --- | Set the starting time of an Event.-trimE :: Event a -> Moment (Event a)-trimE (E t xs) s-    | s <= t = E s $ replicate (t-s) Nothing ++ xs-    | s >  t = E s $ drop (s-t) xs+-- | Event is modeled by an /infinite/ list of 'Maybe' values.+-- It is isomorphic to @Time -> Maybe a@.+--+-- 'Nothing' indicates that no occurrence happens,+-- while 'Just' indicates that an occurrence happens.+newtype Event a = E { unE :: [Maybe a] } deriving (Show) --- | Set the starting time of an Event.-trimB :: Behavior a -> Moment (Behavior a)-trimB (B t x xs) s-    | s <= t = B s x $ replicate (t-s) x ++ xs-    | s >  t = B s (last ys) zs-        where-        (ys,zs) = splitAt (s-t) xs+-- | Behavior is modeled by an /infinite/ list of values.+-- It is isomorphic to @Time -> a@.+newtype Behavior a = B { unB :: [a] } deriving (Show) --- Synchronize two entities-syncEE ~ex@(E tx _)   ~ey@(E ty _)   = (ex `trimE` t, ey `trimE` t)-    where t = min tx ty-syncBE ~bx@(B tx _ _) ~ey@(E ty _)   = (bx `trimB` t, ey `trimE` t)-    where t = min tx ty-syncBB ~bx@(B tx _ _) ~by@(B ty _ _) = (bx `trimB` t, by `trimB` t)-    where t = min tx ty+interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]+interpret f as =+    take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing)  {------------------------------------------------------------------------------    Basic Combinators+    First-order ------------------------------------------------------------------------------}-interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]-interpret f as = zipWith const bs as-    where-    input  = E epoch (as ++ repeat Nothing)-    output = f input (epoch-7) `trimE` epoch-    E _ bs = output-    -- build network before epoch, but start external event at epoch--never :: Event a-never = E epoch (repeat Nothing)--filterJust :: Event (Maybe a) -> Event a-filterJust (E t xs) = E t (map join xs)+instance Functor Event where+    fmap f (E xs) = E (fmap (fmap f) xs) -unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f ex ey = E t $ zipWith g xs ys-    where-    (E t xs, E _ ys) = syncEE ex ey+instance Functor Behavior where+    fmap f (B xs) = B (fmap f xs) -    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+instance Applicative Behavior where+    pure x          = B $ repeat x+    (B f) <*> (B x) = B $ zipWith ($) f x -mapE f = applyE (pureB f)+never :: Event a+never = E $ repeat Nothing -applyE :: Behavior (a -> b) -> Event a -> Event b-applyE bf ex = E t $ zipWith (\f x -> fmap f x) (f:fs) xs+unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a+unionWith f (E xs) (E ys) = E $ zipWith combine xs ys     where-    (B t f fs, E _ xs) = syncBE bf ex---- applicative functor-pureB x = B epoch x (repeat x)+    combine (Just x) (Just y) = Just $ f x y+    combine (Just x) Nothing  = Just x+    combine Nothing  (Just y) = Just y+    combine Nothing  Nothing  = Nothing -applyB :: Behavior (a -> b) -> Behavior a -> Behavior b-applyB bf bx = B t (f x) $ zipWith ($) fs xs-    where-    (B t f fs, B _ x xs) = syncBB bf bx+filterJust :: Event (Maybe a) -> Event a+filterJust = E . fmap join . unE -mapB f = applyB (pureB f)+apply :: Behavior (a -> b) -> Event a -> Event b+apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE  {------------------------------------------------------------------------------    Accumulation+    Moment and accumulation ------------------------------------------------------------------------------}--- Turn first occurence into `Nothing`.-smotherFirst :: Event a -> Event a-smotherFirst (E t (_:xs)) = E t (Nothing:xs)+newtype Moment a = M { unM :: Time -> a } -accumE :: a -> Event (a -> a) -> Moment (Event a)-accumE x e time = E time $ go x xs-    where-    E _ xs = smotherFirst $ e `trimE` time+instance Functor     Moment where fmap f = M . fmap f . unM+instance Applicative Moment where+    pure   = M . const+    (<*>)  = ap+instance Monad Moment where+    return = pure+    (M m) >>= k = M $ \time -> unM (k $ m time) time -    go x (Nothing:fs) = Nothing : go x fs-    go x (Just f :fs) = let y = f x in y `seq` (Just y:go y fs)+instance MonadFix Moment where+    mfix f = M $ mfix (unM . f) -stepperB :: a -> Event a -> Moment (Behavior a)-stepperB x e time = B time x $ go x xs+-- Forget all event occurences before a particular time+forgetE :: Time -> Event a -> [Maybe a]+forgetE time (E xs) = drop time xs++stepper :: a -> Event a -> Moment (Behavior a)+stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)     where-    E _ xs = smotherFirst $ e `trimE` time+    step i ~(x:xs) = i : step next xs+        where next = case x of+                        Just i  -> i+                        Nothing -> i -    go x (Nothing:ys) = x : go x ys-    go x (Just y :ys) = y : go y ys+-- Expressed using recursion and the other primitives+-- FIXME: Strictness!+accumE :: a -> Event (a -> a) -> Moment (Event a)+accumE a e1 = mdo+    let e2 = ((\a f -> f a) <$> b) `apply` e1+    b <- stepper a e2+    return e2  {------------------------------------------------------------------------------    Dynamic Event Switching+    Higher-order ------------------------------------------------------------------------------}-{--instance Monad Moment where-    return  = const-    m >>= g = \time -> g (m time) time--}- valueB :: Behavior a -> Moment a-valueB b time = x-    where B _ x _ = b `trimB` time+valueB (B b) = M $ \time -> b !! time  observeE :: Event (Moment a) -> Event a-observeE (E t xs) = E t $ zipWith (\time -> fmap ($ time)) [t..] xs+observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE -switchE :: Event (Event a) -> Event a-switchE (E t xs) = E t $ go t (repeat Nothing) xs+switchE :: Event (Event a) -> Moment (Event a)+switchE es = M $ \t -> E $+    replicate t Nothing ++ switch (unE never) (forgetE t (forgetDiagonalE es))     where-    go time (y:ys) (Nothing:es) = y : go (time+1) ys es-    go time (y:ys) (Just e :es) = y : go (time+1) zs es-        where-        E _ zs = e `trimE` (time + 1)+    switch (x:xs) (Nothing : ys) = x : switch xs ys+    switch (x: _) (Just xs : ys) = x : switch (tail xs) ys -switchB :: Behavior a -> Event (Behavior a) -> Behavior a-switchB b x = B t y $ go t ys es-    where-    (B t y ys, E _ es) = syncBE b x+forgetDiagonalE :: Event (Event a) -> Event [Maybe a]+forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE -    go time (y:ys) (Nothing:es) = y : go (time+1) ys es-    go time _      (Just b :es) = z : go (time+1) zs es-        where B _ z zs = b `trimB` (time+1)+switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB b e = diagonalB <$> stepper b e++diagonalB :: Behavior (Behavior a) -> Behavior a+diagonalB = B . zipWith (\time xs -> xs !! time) [0..] . map unB . unB

@@ -29,8 +29,6 @@     , nAlwaysP        :: !(Maybe (Pulse ()))   -- Pulse that always fires.     } -instance Show Network where show = error "instance Show Network not implemented."- type Inputs        = ([SomeNode], Lazy.Vault) type EvalNetwork a = Network -> IO (a, Network) type Step          = EvalNetwork (IO ())

@@ -49,7 +49,7 @@         -- , testModelMatchM "valueB_recursive1" valueB_recursive1         -- , testModelMatchM "valueB_recursive2" valueB_recursive2         , testModelMatchM "dynamic_apply"       dynamic_apply-        , testModelMatch  "switchE1"            switchE1+        , testModelMatchM "switchE1"            switchE1         , testModelMatchM "switchB1"            switchB1         , testModelMatchM "switchB2"            switchB2         ]@@ -225,13 +225,13 @@ switchB1 e = do     b0 <- stepper 0 e     b1 <- stepper 0 e-    let b = switchB b0 $ (\x -> if odd x then b1 else b0) <$> e+    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e     return $ b <@ e  switchB2 e = do     b0 <- stepper 0 $ filterE even e     b1 <- stepper 1 $ filterE odd  e-    let b = switchB b0 $ (\x -> if odd x then b1 else b0) <$> e+    b  <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e     return $ b <@ e  {-----------------------------------------------------------------------------

@@ -44,14 +44,14 @@ 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)+mapE f (E x y)                  = E (fmap f x) (Y.mapE f y)+applyE ~(B x1 y1) (E x2 y2)     = E (X.apply x1 x2) (Y.applyE y1 y2)  instance Functor Event where fmap = mapE -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)+pureB a                         = B (pure a) (Y.pureB a)+applyB (B x1 y1) (B x2 y2)      = B (x1 <*> x2) (Y.applyB y1 y2)+mapB f (B x y)                  = B (fmap f x) (Y.mapB f y)  instance Functor     Behavior where fmap = mapB instance Applicative Behavior where pure = pureB; (<*>) = applyB@@ -74,24 +74,24 @@     (fmap ex $ X.accumE a x)     (fmap ey $ Y.accumE a y) stepperB a ~(E x y) = M-    (fmap bx $ X.stepperB a x)+    (fmap bx $ X.stepper  a x)     (fmap by $ Y.stepperB a y) stepper            = stepperB  valueB ~(B x y) = M (X.valueB x) (Y.valueB y)  observeE :: Event (Moment a) -> Event a-observeE (E x y) = E (X.observeE $ X.mapE fstM x) (Y.observeE $ Y.mapE sndM y)+observeE (E x y) = E (X.observeE $ fmap fstM x) (Y.observeE $ Y.mapE sndM y) -switchE :: Event (Event a) -> Event a-switchE (E x y) = E-    (X.switchE $ X.mapE (fstE) x)-    (Y.switchE $ Y.mapE (sndE) y)+switchE :: Event (Event a) -> Moment (Event a)+switchE (E x y) = M+    (fmap ex $ X.switchE $   fmap (fstE) x)+    (fmap ey $ Y.switchE $ Y.mapE (sndE) y) -switchB :: Behavior a -> Event (Behavior a) -> Behavior a-switchB (B x y) (E xe ye) = B-    (X.switchB x $ X.mapE (fstB) xe)-    (Y.switchB y $ Y.mapE (sndB) ye)+switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)+switchB (B x y) (E xe ye) = M+    (fmap bx $ X.switchB x $   fmap (fstB) xe)+    (fmap by $ Y.switchB y $ Y.mapE (sndB) ye)  {-----------------------------------------------------------------------------     Derived combinators