diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ Changelog for the `reactive-banana` package ------------------------------------------- +**version 0.9.0.0** + +* Implement garbage collection for dynamically switched events. +* Fix issue [#79][] where recursive declarations would sometimes result in dropped events. +* Limit value recursion in the `Moment` monad slightly. +* Change `initial` and `valueB` to behave subtly different when it comes to value recursion in the `Moment` monad. +* Add `Functor`, `Applicative` and `Monad` instances for the `FrameworksMoment` type. +* Depend on the [pqueues][] package instead of the [psqueues][] package again, as the former has been updated to work with the current version of GHC. + [#79]: https://github.com/HeinrichApfelmus/reactive-banana/issues/79 + **version 0.8.1.2** * Depend on the [psqueues][] package instead of the [pqueue][] package for the priority queue. diff --git a/doc/examples/Bug.hs b/doc/examples/Bug.hs new file mode 100644 --- /dev/null +++ b/doc/examples/Bug.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RecursiveDo #-} +module RBBug where + +import Reactive.Banana +import Reactive.Banana.Frameworks + +data State = State { stateCounter :: Int } + +test :: Int -> IO () +test n = do + compile $ network n + return () + +network :: Frameworks t => Int -> Moment t () +network 1 = mdo + let state = pure (State 0) -- switchB (pure (State 0)) never + positivityChanges <- changes isPositive + reactimate' (fmap (fmap print) positivityChanges) + let isPositive = fmap ((>= 0) . stateCounter) state + return () +network 2 = mdo + let b = stepper (State 0) e + e <- execute $ (\a -> FrameworksMoment $ return a) <$> (b <@ never) + return () diff --git a/reactive-banana.cabal b/reactive-banana.cabal --- a/reactive-banana.cabal +++ b/reactive-banana.cabal @@ -1,5 +1,5 @@ Name: reactive-banana -Version: 0.8.1.2 +Version: 0.9.0.0 Synopsis: Library for functional reactive programming (FRP). Description: Reactive-banana is a library for Functional Reactive Programming (FRP). @@ -13,14 +13,10 @@ . No semantic bugs expected. . - Significant API changes are likely in future versions, - though the main interface is beginning to stabilize. + Significant API changes are planned for version 1.0. . The library features an efficient, push-driven implementation and has seen some optimization work. - However, the inner loop still has a rather large constant factor overhead. - Moreover, there is currently /no/ garbage collection for events that are - created dynamically with @Reactive.Banana.Switch@. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3 @@ -50,24 +46,14 @@ Library hs-source-dirs: src - - extensions: RecursiveDo, - Rank2Types, ScopedTypeVariables, - ExistentialQuantification, - TypeSynonymInstances, FlexibleInstances, - NoMonomorphismRestriction - + build-depends: base >= 4.2 && < 5, containers >= 0.5 && < 0.6, transformers >= 0.2 && < 0.5, - vault == 0.3.* - - extensions: EmptyDataDecls, - BangPatterns - - build-depends: unordered-containers >= 0.2.1.0 && < 0.3, + vault == 0.3.*, + unordered-containers >= 0.2.1.0 && < 0.3, hashable >= 1.1 && < 1.3, - psqueues >= 0.2 && < 0.3 + pqueue >= 1.0 && < 1.4 -- CPP-options: -DUseExtensions @@ -83,18 +69,21 @@ Reactive.Banana.Switch other-modules: + Control.Monad.Trans.ReaderWriterIO, + Control.Monad.Trans.RWSIO, Reactive.Banana.Internal.Combinators, Reactive.Banana.Internal.Phantom, Reactive.Banana.Prim.Combinators, Reactive.Banana.Prim.Compile, - Reactive.Banana.Prim.Dated, Reactive.Banana.Prim.Dependencies, Reactive.Banana.Prim.Evaluation, + Reactive.Banana.Prim.Graph, Reactive.Banana.Prim.IO, - Reactive.Banana.Prim.Order, + Reactive.Banana.Prim.OrderedBag, Reactive.Banana.Prim.Plumbing, Reactive.Banana.Prim.Test, Reactive.Banana.Prim.Types, + Reactive.Banana.Prim.Util, Reactive.Banana.Types Test-Suite tests @@ -106,4 +95,4 @@ test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, reactive-banana, vault, containers, transformers, - unordered-containers, hashable, psqueues + unordered-containers, hashable, psqueues, pqueue diff --git a/src/Control/Monad/Trans/RWSIO.hs b/src/Control/Monad/Trans/RWSIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/RWSIO.hs @@ -0,0 +1,84 @@ +module Control.Monad.Trans.RWSIO ( + -- * Synopsis + -- | An implementation of the reader/writer/state monad transformer + -- using an 'IORef'. + + -- * Documentation + RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef +import Data.Monoid + +{----------------------------------------------------------------------------- + Type and class instances +------------------------------------------------------------------------------} +data Tuple r w s = Tuple !r !(IORef w) !(IORef s) + +newtype RWSIOT r w s m a = R { run :: Tuple r w s -> m a } + +instance Functor m => Functor (RWSIOT r w s m) where fmap = fmapR + +instance Applicative m => Applicative (RWSIOT r w s m) where + pure = pureR + (<*>) = apR + +instance Monad m => Monad (RWSIOT r w s m) where + return = returnR + (>>=) = bindR + +instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix = mfixR +instance MonadIO m => MonadIO (RWSIOT r w s m) where liftIO = liftIOR +instance MonadTrans (RWSIOT r w s) where lift = liftR + +{----------------------------------------------------------------------------- + Functions +------------------------------------------------------------------------------} +liftIOR m = R $ \_ -> liftIO m +liftR m = R $ \_ -> m +fmapR f m = R $ \x -> fmap f (run m x) +returnR a = R $ \_ -> return a +bindR m k = R $ \x -> run m x >>= \a -> run (k a) x +mfixR f = R $ \x -> mfix (\a -> run (f a) x) +pureR a = R $ \_ -> pure a +apR f a = R $ \x -> run f x <*> run a x + +rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a +rwsT f = do + r <- ask + s <- get + (a,s,w) <- liftIOR $ f r s + put s + tell w + return a + +runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w)) +runRWSIOT m r s = do + w' <- liftIO $ newIORef mempty + s' <- liftIO $ newIORef s + a <- run m (Tuple r w' s') + s <- liftIO $ readIORef s' + w <- liftIO $ readIORef w' + return (a,s,w) + +tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m () +tell w = R $ \(Tuple _ w' _) -> liftIO $ modifyIORef w' (`mappend` w) + +ask :: Monad m => RWSIOT r w s m r +ask = R $ \(Tuple r _ _) -> return r + +get :: MonadIO m => RWSIOT r w s m s +get = R $ \(Tuple _ _ s') -> liftIO $ readIORef s' + +put :: MonadIO m => s -> RWSIOT r w s m () +put s = R $ \(Tuple _ _ s') -> liftIO $ writeIORef s' s + +test :: RWSIOT String String () IO () +test = do + c <- ask + tell c diff --git a/src/Control/Monad/Trans/ReaderWriterIO.hs b/src/Control/Monad/Trans/ReaderWriterIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/ReaderWriterIO.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeFamilies #-} +module Control.Monad.Trans.ReaderWriterIO ( + -- * Synopsis + -- | An implementation of the reader/writer monad transformer + -- using an 'IORef' for the writer. + + -- * Documentation + ReaderWriterIOT, readerWriterIOT, runReaderWriterIOT, tell, listen, ask, local, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef +import Data.Monoid + +{----------------------------------------------------------------------------- + Type and class instances +------------------------------------------------------------------------------} +newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a } + +instance Functor m => Functor (ReaderWriterIOT r w m) where fmap = fmapR + +instance Applicative m => Applicative (ReaderWriterIOT r w m) where + pure = pureR + (<*>) = apR + +instance Monad m => Monad (ReaderWriterIOT r w m) where + return = returnR + (>>=) = bindR + +instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR +instance MonadIO m => MonadIO (ReaderWriterIOT r w m) where liftIO = liftIOR +instance MonadTrans (ReaderWriterIOT r w) where lift = liftR + +instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where + mempty = return () + mx `mappend` my = mx >> my + +{----------------------------------------------------------------------------- + Functions +------------------------------------------------------------------------------} +liftIOR m = ReaderWriterIOT $ \x y -> liftIO m + +liftR m = ReaderWriterIOT $ \x y -> m + +fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y) + +returnR a = ReaderWriterIOT $ \_ _ -> return a + +bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y + +mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y) + +pureR a = ReaderWriterIOT $ \_ _ -> pure a + +apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y + +readerWriterIOT :: (MonadIO m, Monoid w) => + (r -> IO (a, w)) -> ReaderWriterIOT r w m a +readerWriterIOT f = do + r <- ask + (a,w) <- liftIOR $ f r + tell w + return a + +runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w) +runReaderWriterIOT m r = do + ref <- liftIO $ newIORef mempty + a <- run m r ref + w <- liftIO $ readIORef ref + return (a,w) + +tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m () +tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w) + +listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w) +listen m = ReaderWriterIOT $ \r ref -> do + a <- run m r ref + w <- liftIO $ readIORef ref + return (a,w) + +local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a +local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref + +ask :: Monad m => ReaderWriterIOT r w m r +ask = ReaderWriterIOT $ \r _ -> return r + +test :: ReaderWriterIOT String String IO () +test = do + c <- ask + tell c diff --git a/src/Reactive/Banana/Combinators.hs b/src/Reactive/Banana/Combinators.hs --- a/src/Reactive/Banana/Combinators.hs +++ b/src/Reactive/Banana/Combinators.hs @@ -76,7 +76,10 @@ -- Useful for testing. interpret :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] interpret f xs = - map toList <$> Prim.interpret (return . unE . f . E) (map Just xs) + map toList <$> Prim.interpret (return . unE . f . E) (map wrap xs) + where + wrap [] = Nothing + wrap xs = Just xs toList :: Maybe [a] -> [a] toList Nothing = [] @@ -174,8 +177,11 @@ mapAccumE :: s -> Prim.Event (s -> (a,s)) -> Prim.Event a mapAccumE acc = - Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE (. snd) + Prim.mapE fst . Prim.accumE (undefined,acc) . Prim.mapE lift + lift f (_,acc) = acc `seq` f acc + + -- strict version of scanl scanl' :: (a -> b -> a) -> a -> [b] -> [a] scanl' f x ys = x : case ys of @@ -312,5 +318,6 @@ -- | Efficient combination of 'accumE' and 'accumB'. mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e)) - where e = accumE (undefined,acc) ((. snd) <$> ef) - + where + e = accumE (undefined,acc) (lift <$> ef) + lift f (_,acc) = acc `seq` f acc diff --git a/src/Reactive/Banana/Frameworks.hs b/src/Reactive/Banana/Frameworks.hs --- a/src/Reactive/Banana/Frameworks.hs +++ b/src/Reactive/Banana/Frameworks.hs @@ -16,7 +16,10 @@ compile, Frameworks, module Control.Event.Handler, fromAddHandler, fromChanges, fromPoll, - reactimate, Future, reactimate', initial, changes, imposeChanges, + reactimate, Future, reactimate', initial, + changes, + -- $changes + imposeChanges, FrameworksMoment(..), execute, liftIOLater, -- $liftIO module Control.Monad.IO.Class, @@ -190,8 +193,13 @@ -- | Output, -- observe the initial value contained in a 'Behavior'. +-- +-- NOTE: To allow for more recursion, the value is returned /lazily/ +-- and not available for pattern matching immediately. +-- +-- If that doesn't work for you, please use 'valueB' instead. initial :: Behavior t a -> Moment t a -initial = M . Prim.initialB . unB +initial = M . Prim.initialBLater . unB -- | Output, -- observe when a 'Behavior' changes. @@ -213,6 +221,26 @@ changes :: Frameworks t => Behavior t a -> Moment t (Event t (Future a)) changes = return . fmap F . singletonsE . Prim.changesB . unB +{- $changes + +Note: If you need a variant of the 'changes' function that does /not/ +have the additional 'Future' type, then the following code snippet +may be useful: + +> plainChanges :: Frameworks t => Behavior t a -> Moment t (Event t a) +> plainChanges b = do +> (e, handle) <- newEvent +> eb <- changes b +> reactimate' $ (fmap handle) <$> eb +> return e + +However, this approach is not recommended, because the result 'Event' +will occur /slightly/ later than the event returned by 'changes'. +In fact, there is no guarantee whatsoever about what /slightly/ means +in this context. Still, it is useful in some cases. + +-} + -- | Impose a different sampling event on a 'Behavior'. -- -- The 'Behavior' will vary continuously as before, but the event returned @@ -227,6 +255,15 @@ newtype FrameworksMoment a = FrameworksMoment { runFrameworksMoment :: forall t. Frameworks t => Moment t a } + +instance Functor FrameworksMoment where + fmap f (FrameworksMoment x) = FrameworksMoment (fmap f x) +instance Applicative FrameworksMoment where + pure x = FrameworksMoment (pure x) + (FrameworksMoment f) <*> (FrameworksMoment x) = FrameworksMoment (f <*> x) +instance Monad FrameworksMoment where + return x = FrameworksMoment (return x) + (FrameworksMoment m) >>= g = FrameworksMoment (m >>= runFrameworksMoment . g) unFM :: FrameworksMoment a -> Moment (FrameworksD,t) a unFM = runFrameworksMoment diff --git a/src/Reactive/Banana/Internal/Combinators.hs b/src/Reactive/Banana/Internal/Combinators.hs --- a/src/Reactive/Banana/Internal/Combinators.hs +++ b/src/Reactive/Banana/Internal/Combinators.hs @@ -14,36 +14,23 @@ import Data.Functor import Data.Functor.Identity import Data.IORef -import qualified Data.Vault.Lazy as Lazy import qualified Reactive.Banana.Prim as Prim -import qualified Reactive.Banana.Prim.Cached as Prim -import Reactive.Banana.Prim.Cached hiding (runCached) +import Reactive.Banana.Prim.Cached type Build = Prim.Build -type Latch = Prim.Latch -type Pulse = Prim.Pulse +type Latch a = Prim.Latch a +type Pulse a = Prim.Pulse a type Future = Prim.Future {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} -type Behavior a = Cached Moment' (Latch a, Pulse ()) -type Event a = Cached Moment' (Pulse a) - -type MomentT m = ReaderT EventNetwork (Prim.BuildT m) -type Moment = MomentT IO -type Moment' = MomentT Identity - -instance (Monad m, MonadFix m, HasCache m) - => HasCache (ReaderT EventNetwork m) where - retrieve key = lift $ retrieve key - write key a = lift $ write key a - -liftBuild :: Monad m => Build a -> MomentT m a -liftBuild = lift . Prim.liftBuild +type Behavior a = Cached Moment (Latch a, Pulse ()) +type Event a = Cached Moment (Pulse a) +type Moment = ReaderT EventNetwork Prim.Build -runCached :: Monad m => Cached Moment' a -> MomentT m a -runCached = mapReaderT Prim.liftBuild . Prim.runCached +liftBuild :: Build a -> Moment a +liftBuild = lift {----------------------------------------------------------------------------- Interpretation @@ -94,16 +81,18 @@ fromAddHandler :: AddHandler a -> Moment (Event a) fromAddHandler addHandler = do - key <- liftIO $ Lazy.newKey - (p, fire) <- liftBuild $ Prim.newInput key + (p, fire) <- liftBuild $ Prim.newInput network <- ask liftIO $ register addHandler $ runStep network . fire return $ Prim.fromPure p addReactimate :: Event (Future (IO ())) -> Moment () addReactimate e = do - p <- runCached e - liftBuild $ Prim.addHandler p id + network <- ask + liftBuild $ Prim.buildLater $ do + -- Run cached computation later to allow more recursion with `Moment` + p <- runReaderT (runCached e) network + Prim.addHandler p id fromPoll :: IO a -> Moment (Behavior a) fromPoll poll = do @@ -154,38 +143,46 @@ {----------------------------------------------------------------------------- Combinators - dynamic event switching ------------------------------------------------------------------------------} -initialB :: Behavior a -> Moment a -initialB b = do +liftBuildFun :: (Build a -> Build b) -> Moment a -> Moment b +liftBuildFun f m = do + r <- ask + liftBuild $ f $ runReaderT m r + +valueB :: Behavior a -> Moment a +valueB b = do ~(l,_) <- runCached b liftBuild $ Prim.readLatch l +initialBLater :: Behavior a -> Moment a +initialBLater = liftBuildFun Prim.buildLaterReadNow . valueB + trimE :: Event a -> Moment (Moment (Event a)) trimE e = do - p <- runCached 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 + -- make sure that the event is added to the network eventually + liftBuildFun Prim.buildLater $ void $ runCached e + return $ return $ e trimB :: Behavior a -> Moment (Moment (Behavior a)) trimB b = do - ~(l,p) <- runCached b -- add behavior to network - return $ return $ fromPure (l,p) -- remember it henceforth + -- make sure that the behavior is added to the network eventually + liftBuildFun Prim.buildLater $ void $ runCached b + return $ return $ b -executeP :: Monad m => Pulse (Moment a) -> MomentT m (Pulse a) +executeP :: Pulse (Moment a) -> Moment (Pulse a) executeP p1 = do - p2 <- liftBuild $ Prim.mapP runReaderT p1 r <- ask - liftBuild $ Prim.executeP p2 r + liftBuild $ do + p2 <- Prim.mapP runReaderT p1 + Prim.executeP p2 r observeE :: Event (Moment a) -> Event a observeE = liftCached1 $ executeP executeE :: Event (Moment a) -> Moment (Event a) executeE e = do - p <- runCached e - result <- executeP p - return $ fromPure result + -- Run cached computation later to allow more recursion with `Moment` + p <- liftBuildFun Prim.buildLaterReadNow $ executeP =<< runCached e + return $ fromPure p switchE :: Event (Moment (Event a)) -> Event a switchE = liftCached1 $ \p1 -> do diff --git a/src/Reactive/Banana/Model.hs b/src/Reactive/Banana/Model.hs --- a/src/Reactive/Banana/Model.hs +++ b/src/Reactive/Banana/Model.hs @@ -17,7 +17,7 @@ stepperB, pureB, applyB, mapB, -- ** Dynamic event switching Moment, - initialB, trimE, trimB, observeE, switchE, switchB, + valueB, trimE, trimB, observeE, switchE, switchB, -- * Interpretation interpret, @@ -111,8 +111,8 @@ m >>= g = \time -> g (m time) time -} -initialB :: Behavior a -> Moment a -initialB (StepperB x _) = return x +valueB :: Behavior a -> Moment a +valueB (StepperB x _) = return x trimE :: Event a -> Moment (Moment (Event a)) trimE e = \now -> \later -> drop (later - now) e diff --git a/src/Reactive/Banana/Prim.hs b/src/Reactive/Banana/Prim.hs --- a/src/Reactive/Banana/Prim.hs +++ b/src/Reactive/Banana/Prim.hs @@ -1,6 +1,7 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} +{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim ( -- * Synopsis -- | This is an internal module, useful if you want to @@ -12,9 +13,12 @@ Step, Network, emptyNetwork, -- * Build FRP networks - Build, liftIOLater, BuildIO, BuildT, liftBuild, compile, + Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile, module Control.Monad.IO.Class, + -- * Caching + module Reactive.Banana.Prim.Cached, + -- * Testing interpret, mapAccumM, mapAccumM_, runSpaceProfile, @@ -31,12 +35,85 @@ -- * Dynamic event switching switchL, executeP, switchP + + -- * Notes + -- $recursion ) where import Control.Monad.IO.Class +import Reactive.Banana.Prim.Cached import Reactive.Banana.Prim.Combinators import Reactive.Banana.Prim.Compile import Reactive.Banana.Prim.IO -import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, liftIOLater) +import Reactive.Banana.Prim.Plumbing (neverP, alwaysP, liftBuild, buildLater, buildLaterReadNow, liftIOLater) import Reactive.Banana.Prim.Types + +{----------------------------------------------------------------------------- + Notes +------------------------------------------------------------------------------} +-- Note [Recursion] +{- $recursion + +The 'Build' monad is an instance of 'MonadFix' and supports value recursion. +However, it is built on top of the 'IO' monad, so the recursion is +somewhat limited. + +The main rule for value recursion in the 'IO' monad is that the action +to be performed must be known in advance. For instance, the following snippet +will not work, because 'putStrLn' cannot complete its action without +inspecting @x@, which is not defined until later. + +> mdo +> putStrLn x +> let x = "Hello recursion" + +On the other hand, whenever the sequence of 'IO' actions can be known +before inspecting any later arguments, the recursion works. +For instance the snippet + +> mdo +> p1 <- mapP p2 +> p2 <- neverP +> return p1 + +works because 'mapP' does not inspect its argument. In other words, +a call @p1 <- mapP undefined@ would perform the same sequence of 'IO' actions. +(Internally, it essentially calls 'newIORef'.) + +With this issue in mind, almost all operations that build 'Latch' +and 'Pulse' values have been carefully implemented to not inspect +their arguments. +In conjunction with the 'Cached' mechanism for observable sharing, +this allows us to build combinators that can be used recursively. +One notable exception is the 'readLatch' function, which must +inspect its argument in order to be able to read its value. + +-} + +test :: Build (Pulse ()) +test = mdo + p1 <- mapP (const ()) p2 + p2 <- neverP + return p1 + +-- Note [LatchStrictness] +{- + +Any value that is stored in the graph over a longer +period of time must be stored in WHNF. + +This implies that the values in a latch must be forced to WHNF +when storing them. That doesn't have to be immediately +since we are tying a knot, but it definitely has to be done +before evaluateGraph is done. + +It also implies that reading a value from a latch must +be forced to WHNF before storing it again, so that we don't +carry around the old collection of latch values. +This is particularly relevant for `applyL`. + +Conversely, since latches are the only way to store values over time, +this is enough to guarantee that there are no space leaks in this regard. + +-} diff --git a/src/Reactive/Banana/Prim/Cached.hs b/src/Reactive/Banana/Prim/Cached.hs --- a/src/Reactive/Banana/Prim/Cached.hs +++ b/src/Reactive/Banana/Prim/Cached.hs @@ -7,16 +7,15 @@ -- and then retrieving values from a cache. -- -- Very useful for observable sharing. - HasCache(..), Cached, runCached, cache, fromPure, don'tCache, liftCached1, liftCached2, ) where -import Control.Monad -import Control.Monad.Fix -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy (Key, newKey) -import System.IO.Unsafe (unsafePerformIO) +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) {----------------------------------------------------------------------------- Cache type @@ -26,44 +25,39 @@ runCached :: Cached m a -> m a runCached (Cached x) = x --- | Type class for monads that have a lazy 'Vault' that can be used as a cache. --- --- The cache has to be lazy in the values in order to be useful for recursion. -class (Monad m, MonadFix m) => HasCache m where - retrieve :: Lazy.Key a -> m (Maybe a) - write :: Lazy.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 cache #-} -cache :: HasCache m => m a -> Cached m a +cache :: (MonadFix m, MonadIO m) => m a -> Cached m a cache m = unsafePerformIO $ do - key <- Lazy.newKey + key <- liftIO $ newIORef Nothing return $ Cached $ do - ma <- retrieve key -- look up calculation result + ma <- liftIO $ readIORef key -- read the cached result case ma of + Just a -> return a -- return the cached result. Nothing -> mdo - write key a -- black-hole result first - a <- m -- evaluate + liftIO $ -- write the result already + writeIORef key (Just a) + a <- m -- evaluate return a - Just a -> return a -- return cached result -- | Return a pure value. Doesn't make use of the cache. -fromPure :: HasCache m => a -> Cached m a +fromPure :: Monad m => a -> Cached m a fromPure = Cached . return -- | Lift an action that is /not/ chached, for instance because it is idempotent. -don'tCache :: HasCache m => m a -> Cached m a +don'tCache :: Monad m => m a -> Cached m a don'tCache = Cached -liftCached1 :: HasCache m => (a -> m b) -> Cached m a -> Cached m b +liftCached1 :: (MonadFix m, MonadIO m) => + (a -> m b) -> Cached m a -> Cached m b liftCached1 f ca = cache $ do a <- runCached ca f a -liftCached2 :: HasCache m => +liftCached2 :: (MonadFix m, MonadIO m) => (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c liftCached2 f ca cb = cache $ do a <- runCached ca diff --git a/src/Reactive/Banana/Prim/Combinators.hs b/src/Reactive/Banana/Prim/Combinators.hs --- a/src/Reactive/Banana/Prim/Combinators.hs +++ b/src/Reactive/Banana/Prim/Combinators.hs @@ -8,13 +8,14 @@ import Control.Monad import Control.Monad.IO.Class -import Reactive.Banana.Prim.Dated (Box(..)) import Reactive.Banana.Prim.Plumbing ( neverP, newPulse, newLatch, cachedLatch - , dependOn, changeParent - , readPulseP, readLatchP, readLatchFutureP, liftBuildP, liftBuildIOP + , dependOn, keepAlive, changeParent + , getValueL + , readPulseP, readLatchP, readLatchFutureP, liftBuildP, ) -import Reactive.Banana.Prim.Types (Latch(..), Future, Pulse, Build, BuildIO) +import qualified Reactive.Banana.Prim.Plumbing (pureL) +import Reactive.Banana.Prim.Types (Latch, Future, Pulse, Build) import Debug.Trace -- debug s = trace s @@ -78,15 +79,15 @@ return p pureL :: a -> Latch a -pureL a = Latch { getValueL = return (pure a) } +pureL = Reactive.Banana.Prim.Plumbing.pureL -- specialization of mapL f = applyL (pureL f) mapL :: (a -> b) -> Latch a -> Latch b -mapL f lx = cachedLatch $ {-# SCC mapL #-} fmap f <$> getValueL lx +mapL f lx = cachedLatch $ {-# SCC mapL #-} f <$> getValueL lx applyL :: Latch (a -> b) -> Latch a -> Latch b applyL lf lx = cachedLatch $ - {-# SCC applyL #-} (<*>) <$> getValueL lf <*> getValueL lx + {-# SCC applyL #-} getValueL lf <*> getValueL lx accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) accumL a p1 = do @@ -108,15 +109,15 @@ switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a) switchL l pl = mdo x <- stepperL l pl - return $ Latch { getValueL = getValueL x >>= \(Box a) -> getValueL a } + return $ cachedLatch $ getValueL x >>= getValueL -executeP :: Pulse (b -> BuildIO a) -> b -> Build (Pulse a) +executeP :: Pulse (b -> Build a) -> b -> Build (Pulse a) executeP p1 b = do p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1 p2 `dependOn` p1 return p2 where - eval (Just x) = Just <$> liftBuildIOP (x b) + eval (Just x) = Just <$> liftBuildP (x b) eval Nothing = return Nothing switchP :: Pulse (Pulse a) -> Build (Pulse a) @@ -137,55 +138,5 @@ p1 <- newPulse "switchP_in" switch :: Build (Pulse ()) p1 `dependOn` pp p2 <- newPulse "switchP_out" eval + p2 `keepAlive` p1 return p2 - -{----------------------------------------------------------------------------- - Notes -------------------------------------------------------------------------------} -{- - -* 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. - -* Note [LatchRecursion] - -... - -* Note [LatchStrictness] - -Any value that is stored in the graph over a longer -period of time must be stored in WHNF. - -This implies that the values in a latch must be forced to WHNF -when storing them. That doesn't have to be immediately -since we are tying a knot, but it definitely has to be done -before evaluateGraph is done. - -It also implies that reading a value from a latch must -be forced to WHNF before storing it again, so that we don't -carry around the old collection of latch values. -This is particularly relevant for `applyL`. - -Conversely, since latches are the only way to store values over time, -this is enough to guarantee that there are no space leaks in this regard. - --} - - diff --git a/src/Reactive/Banana/Prim/Compile.hs b/src/Reactive/Banana/Prim/Compile.hs --- a/src/Reactive/Banana/Prim/Compile.hs +++ b/src/Reactive/Banana/Prim/Compile.hs @@ -1,13 +1,17 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} +{-# LANGUAGE BangPatterns #-} module Reactive.Banana.Prim.Compile where -import Data.Functor -import Data.IORef -import qualified Data.Vault.Lazy as Lazy +import Control.Exception (evaluate) +import Control.Monad (void) +import Data.Functor +import Data.IORef + import Reactive.Banana.Prim.Combinators import Reactive.Banana.Prim.IO +import qualified Reactive.Banana.Prim.OrderedBag as OB import Reactive.Banana.Prim.Plumbing import Reactive.Banana.Prim.Types @@ -17,8 +21,26 @@ -- | Change a 'Network' of pulses and latches by -- executing a 'BuildIO' action. compile :: BuildIO a -> Network -> IO (a, Network) -compile = flip runBuildIO +compile m state1 = do + let time1 = nTime state1 + outputs1 = nOutputs state1 + theAlwaysP <- case nAlwaysP state1 of + Just x -> return x + Nothing -> do + (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ()) + return x + + (a, topology, os) <- runBuildIO (nTime state1, theAlwaysP) m + doit topology + + let state2 = Network + { nTime = next time1 + , nOutputs = foldr OB.insert outputs1 os + , nAlwaysP = Just theAlwaysP + } + return (a,state2) + {----------------------------------------------------------------------------- Testing ------------------------------------------------------------------------------} @@ -30,10 +52,9 @@ -- that the 'sequence' function does not compute its result lazily. interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b] interpret f xs = do - key <- Lazy.newKey o <- newIORef Nothing let network = do - (pin, sin) <- liftBuild $ newInput key + (pin, sin) <- liftBuild $ newInput pmid <- f pin pout <- liftBuild $ mapP return pmid liftBuild $ addHandler pout (writeIORef o . Just) @@ -52,17 +73,24 @@ mapAccumM go state xs -- run several steps --- | Execute an FRP network with a sequence of inputs, but discard results. +-- | Execute an FRP network with a sequence of inputs. +-- Make sure that outputs are evaluated, but don't display their values. -- -- Mainly useful for testing whether there are space leaks. -runSpaceProfile :: (Pulse a -> BuildIO void) -> [a] -> IO () +runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO () runSpaceProfile f xs = do - key <- Lazy.newKey let g = do - (p1, fire) <- liftBuild $ newInput key - f p1 + (p1, fire) <- liftBuild $ newInput + p2 <- f p1 + p3 <- mapP return p2 -- wrap into Future + addHandler p3 (\b -> void $ evaluate b) return fire - (fire,network) <- compile g emptyNetwork + (step,network) <- compile g emptyNetwork + + let fire x s1 = do + (outputs, s2) <- step x s1 + outputs -- don't forget to execute outputs + return ((), s2) mapAccumM_ fire network xs @@ -76,8 +104,8 @@ -- | Strict 'mapAccum' for a monad. Discards results. mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m () -mapAccumM_ _ _ [] = return () -mapAccumM_ f s0 (x:xs) = do +mapAccumM_ _ _ [] = return () +mapAccumM_ f !s0 (x:xs) = do (_,s1) <- f x s0 mapAccumM_ f s1 xs diff --git a/src/Reactive/Banana/Prim/Dated.hs b/src/Reactive/Banana/Prim/Dated.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Dated.hs +++ /dev/null @@ -1,106 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Reactive.Banana.Prim.Dated ( - -- | A cache with timestamps. - - -- * Time - Time, ancient, beginning, next, - -- * Cache - Vault, Key, empty, newKey, findWithDefault, - -- * Strictness - Box(..), - -- * Computations - Dated, runDated, update', cache, - - ) where - -import Control.Applicative hiding (empty) -import Control.Monad.Trans.RWS -import Data.Functor -import Data.Monoid -import qualified Data.Vault.Strict as Strict -import Prelude hiding (lookup) - -{----------------------------------------------------------------------------- - Time monoid -------------------------------------------------------------------------------} -newtype Time = T Integer deriving (Eq, Ord, Show, Read) - -ancient :: Time -ancient = T 0 - -beginning :: Time -beginning = T 1 - -next :: Time -> Time -next (T n) = T (n+1) - -instance Monoid Time where - mappend (T x) (T y) = T (max x y) - mempty = ancient - -{----------------------------------------------------------------------------- - Strictness -------------------------------------------------------------------------------} --- | A strict box of potentially lazy value. -data Box a = Box { unBox :: a } - -instance Functor Box where - fmap f (Box x) = Box (f x) - -instance Applicative Box where - pure x = Box x - (Box f) <*> (Box x) = Box (f x) - -{----------------------------------------------------------------------------- - Cache data type -------------------------------------------------------------------------------} -newKey :: IO (Key a) -newKey = Strict.newKey - -empty :: Vault -empty = Strict.empty - -type Vault = Strict.Vault -type Key a = Strict.Key (Timed a) - -{----------------------------------------------------------------------------- - Cached computations -------------------------------------------------------------------------------} -type Dated = RWS () Time Vault -data Timed a = Timed !(Box a) !Time - -runDated :: Dated a -> Vault -> (a, Vault) -runDated m s1 = let (a,s2,_) = runRWS m () s1 in (a,s2) - -findWithDefault :: a -> Key a -> Dated (Box a) -findWithDefault a key = do - ma <- Strict.lookup key <$> get - case ma of - Nothing -> return (Box a) - Just (Timed a t) -> tell t >> return a - --- | Update a value inside the cache. --- The value will be evaluated to WHNF when the cache is evaluated to WHNF. -update' :: Key a -> Time -> a -> Vault -> Vault -update' key t a = Strict.insert key (Timed (a `seq` Box a) t) - -cache :: Key a -> Dated (Box a) -> Dated (Box a) --- cache key m = m --- Observation: If a is a function type, then forcing --- it will not necessarily remove all the function application things. -cache key m = do - (aNew, timeNew) <- listen m - let refresh = do - modify $ Strict.insert key (Timed aNew timeNew) - return aNew - - ma <- Strict.lookup key <$> get - case ma of - Just (Timed aOld timeOld) - | timeOld >= timeNew -> do -- cache is more recent - tell timeOld - return aOld - | otherwise -> refresh -- cache is too old - Nothing -> refresh diff --git a/src/Reactive/Banana/Prim/Dependencies.hs b/src/Reactive/Banana/Prim/Dependencies.hs --- a/src/Reactive/Banana/Prim/Dependencies.hs +++ b/src/Reactive/Banana/Prim/Dependencies.hs @@ -1,172 +1,107 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Reactive.Banana.Prim.Dependencies ( - -- | Utilities for operating with dependency graphs. - Deps, dOrder, empty, allChildren, children, parents, - addChild, changeParent, - - Continue(..), maybeContinue, traverseDependencies, - - DepsQueue, emptyQ, insert, minView, + -- | Utilities for operating on node dependencies. + addChild, changeParent, buildDependencies, ) where -import Control.Monad.Trans.Writer -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Hashable -import qualified Data.IntPSQ as Q - -import Reactive.Banana.Prim.Order -import qualified Reactive.Banana.Prim.Order as Order +import Control.Monad +import Data.Functor +import Data.Monoid +import System.Mem.Weak -type Map = Map.HashMap -type Set = Set.HashSet +import qualified Reactive.Banana.Prim.Graph as Graph +import Reactive.Banana.Prim.Types +import Reactive.Banana.Prim.Util {----------------------------------------------------------------------------- - Dependency graph + Accumulate dependency information for nodes ------------------------------------------------------------------------------} --- | A dependency graph. -data Deps a = Deps - { dChildren :: Map a [a] -- children depend on their parents - , dParents :: Map a [a] - , dOrder :: Order a - } deriving (Show) - --- | Representation of the depencencies as an association list of nodes --- to children. -allChildren :: Deps a -> [(a, [a])] -allChildren = Map.toList . dChildren - --- | Children of a node. -children deps x = - {-# SCC children #-} maybe [] id . Map.lookup x $ dChildren deps - --- | Parents of a node. -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 - , dOrder = Order.flat - } +-- | Add a new child node to a parent node. +addChild :: SomeNode -> SomeNode -> DependencyBuilder +addChild parent child = (Endo $ Graph.insertEdge (parent,child), mempty) --- | Add a new dependency. -addChild :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a -addChild parent child deps1@(Deps{..}) = deps2 - where - deps2 = Deps - { dChildren = Map.insertWith (++) parent [child] dChildren - , dParents = Map.insertWith (++) child [parent] dParents - , dOrder = ensureAbove child parent dOrder - } - when b f = if b then f else id +-- | Assign a new parent to a child node. +-- INVARIANT: The child may have only one parent node. +changeParent :: Pulse a -> Pulse b -> DependencyBuilder +changeParent child parent = (mempty, [(P child, P parent)]) --- | Change the parent of the first argument to be the second one. -changeParent :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a -changeParent child parent deps1@(Deps{..}) = deps2 +-- | Execute the information in the dependency builder +-- to change network topology. +buildDependencies :: DependencyBuilder -> IO () +buildDependencies (Endo f, parents) = do + sequence_ [x `doAddChild` y | x <- Graph.listParents gr, y <- Graph.getChildren gr x] + sequence_ [x `doChangeParent` y | (P x, P y) <- parents] where - deps2 = Deps - { dChildren = Map.insertWith (++) parent [child] - $ removeChild parentsOld dChildren - , dParents = Map.insert child [parent] dParents - , dOrder = recalculateParent child parent (parents deps2) dOrder - } - parentsOld = parents deps1 child - removeChild1 = Map.adjust (filter (/= child)) - removeChild = concatenate . map removeChild1 - concatenate = foldr (.) id + gr = f Graph.emptyGraph {----------------------------------------------------------------------------- - Traversal + Set dependencies of individual notes ------------------------------------------------------------------------------} --- | Data type for signaling whether to continue a traversal or not. -data Continue = Children | Done - deriving (Eq, Ord, Show, Read) - --- | Convert a 'Maybe' value into a 'Continue' decision. -maybeContinue :: Maybe a -> Continue -maybeContinue Nothing = Done -maybeContinue (Just _) = Children - --- | Starting with a set of root nodes, peform a monadic action --- for each node. If the action returns 'Children', its children will also --- be traversed at some point. --- However, all nodes are traversed in dependency order: --- A child node is only traversed when all its parent nodes have been traversed. -traverseDependencies :: forall a m. (Eq a, Hashable a, Monad m) - => (a -> m Continue) -> Deps a -> [a] -> m () -traverseDependencies f deps roots = go $ insertList roots emptyQ - where - order = dOrder deps - insertList xs q = foldr (\x -> insert (level x order) x) q xs +-- | Add a child node to the children of a parent 'Pulse'. +connectChild + :: Pulse a -- ^ Parent node whose '_childP' field is to be updated. + -> SomeNode -- ^ Child node to add. + -> IO (Weak SomeNode) + -- ^ Weak reference with the child as key and the parent as value. +connectChild parent child = do + w <- mkWeakNodeValue child child + modify' parent $ update childrenP (w:) + mkWeakNodeValue child (P parent) -- child keeps parent alive - go q1 = case minView q1 of - Nothing -> return () - Just (a, q2) -> do - continue <- f a - case continue of - Done -> go q2 - Children -> go $ insertList (children deps a) q2 +-- | Add a child node to a parent node and update evaluation order. +doAddChild :: SomeNode -> SomeNode -> IO () +doAddChild (P parent) (P child) = do + level1 <- _levelP <$> readRef child + level2 <- _levelP <$> readRef parent + let level = level1 `max` (level2 + 1) + w <- parent `connectChild` (P child) + modify' child $ set levelP level . update parentsP (w:) +doAddChild (P parent) node = void $ parent `connectChild` node --- | Queue for traversing dependencies. --- --- The 'Int' is a key supply for the priority search queue. -data DepsQueue a = DQ !(Q.IntPSQ Level a) !(Set a) Int +-- | Remove a node from its parents and all parents from this node. +removeParents :: Pulse a -> IO () +removeParents child = do + c@Pulse{_parentsP} <- readRef child + -- delete this child (and dead children) from all parent nodes + forM_ _parentsP $ \w -> do + Just (P parent) <- deRefWeak w -- get parent node + finalize w -- severe connection in garbage collector + let isGoodChild w = not . maybe True (== P child) <$> deRefWeak w + new <- filterM isGoodChild . _childrenP =<< readRef parent + modify' parent $ set childrenP new + -- replace parents by empty list + put child $ c{_parentsP = []} -emptyQ :: DepsQueue a -emptyQ = DQ Q.empty Set.empty 0 +-- | Set the parent of a pulse to a different pulse. +doChangeParent :: Pulse a -> Pulse b -> IO () +doChangeParent child parent = do + -- remove all previous parents and connect to new parent + removeParents child + w <- parent `connectChild` (P child) + modify' child $ update parentsP (w:) -insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a -insert k a q@(DQ queue seen n) = {-# SCC insert #-} - if a `Set.member` seen - then q - else DQ (Q.insert (n+1) k a queue) (Set.insert a seen) (n+1) + -- calculate level difference between parent and node + levelParent <- _levelP <$> readRef parent + levelChild <- _levelP <$> readRef child + let d = levelParent - levelChild + 1 + -- level parent - d = level child - 1 -minView :: DepsQueue a -> Maybe (a, DepsQueue a) -minView (DQ queue seen n) = {-# SCC minView #-} case Q.minView queue of - Nothing -> Nothing - Just (_, _, a, queue2) -> Just (a, DQ queue2 seen n) + -- lower all parents of the node if the parent was higher than the node + when (d > 0) $ do + parents <- Graph.dfs (P parent) getParents + forM_ parents $ \(P node) -> do + modify' node $ update levelP (subtract d) {----------------------------------------------------------------------------- - Small tests + Helper functions ------------------------------------------------------------------------------} -test1 = id - . changeParent 'C' 'A' - . addChild 'C' 'D' - . addChild 'B' 'C' - . addChild 'B' 'D' - . addChild 'A' 'B' - . addChild 'a' 'B' - $ empty - -{- test2 = - a - / \ - b d A - | | | - c e B - \ / \ / - f g - \ / - h - --} -test2 = id - . addChild 'g' 'h' . addChild 'e' 'g' - . addChild 'B' 'g' . addChild 'A' 'B' - . addChild 'f' 'h' - . addChild 'e' 'f' . addChild 'd' 'e' . addChild 'a' 'd' - . addChild 'c' 'f' . addChild 'b' 'c' . addChild 'a' 'b' - $ empty - -test3 = changeParent 'A' 'f' $ test2 +getChildren :: SomeNode -> IO [SomeNode] +getChildren (P p) = deRefWeaks =<< fmap _childrenP (readRef p) +getChildren _ = return [] -listChildren :: (Eq a, Hashable a) => Deps a -> a -> [a] -listChildren deps x = snd $ runWriter $ traverseDependencies f deps [x] - where f x = tell [x] >> return Children - +getParents :: SomeNode -> IO [SomeNode] +getParents (P p) = deRefWeaks =<< fmap _parentsP (readRef p) +getParents _ = return [] diff --git a/src/Reactive/Banana/Prim/Evaluation.hs b/src/Reactive/Banana/Prim/Evaluation.hs --- a/src/Reactive/Banana/Prim/Evaluation.hs +++ b/src/Reactive/Banana/Prim/Evaluation.hs @@ -1,75 +1,120 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE RecursiveDo, BangPatterns #-} -module Reactive.Banana.Prim.Evaluation where +{-# LANGUAGE RecordWildCards, BangPatterns #-} +module Reactive.Banana.Prim.Evaluation ( + step + ) where -import qualified Control.Exception as Strict (evaluate) -import Data.Monoid -import Data.List (foldl') +import qualified Control.Exception as Strict (evaluate) +import Control.Monad (foldM) +import Control.Monad (join) +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.RWSIO as RWS +import qualified Control.Monad.Trans.ReaderWriterIO as RW +import Data.Functor +import Data.Maybe +import qualified Data.PQueue.Prio.Min as Q +import qualified Data.Vault.Lazy as Lazy +import System.Mem.Weak -import qualified Reactive.Banana.Prim.Dated as Dated -import qualified Reactive.Banana.Prim.Dependencies as Deps -import Reactive.Banana.Prim.Order +import qualified Reactive.Banana.Prim.OrderedBag as OB import Reactive.Banana.Prim.Plumbing import Reactive.Banana.Prim.Types +import Reactive.Banana.Prim.Util +type Queue = Q.MinPQueue Level + {----------------------------------------------------------------------------- - Graph evaluation + Evaluation step ------------------------------------------------------------------------------} -- | Evaluate all the pulses in the graph, -- Rebuild the graph as necessary and update the latch values. step :: Inputs -> Step -step (pulse1, roots) state1 = {-# SCC step #-} mdo - let graph1 = nGraph state1 - latch1 = nLatchValues state1 - time1 = nTime state1 - - -- evaluate pulses while recalculating some latch values - ((_, latchUpdates, output), state2) - <- runBuildIO state1 - $ runEvalP pulse1 - $ evaluatePulses graph1 roots - - let - -- updated graph dependencies - graph2 = nGraph state2 - -- update latch values from accumulations - latch2 = appEndo latchUpdates $ nLatchValues state2 - -- calculate output actions, possibly recalculating more latch values - (actions, latch3) = Dated.runDated output latch2 +step (inputs,pulses) + Network{ nTime = time1 + , nOutputs = outputs1 + , nAlwaysP = Just alwaysP -- we assume that this has been built already + } + = {-# SCC step #-} do - -- make sure that the latch values are in WHNF - Strict.evaluate $ {-# SCC evaluate #-} latch3 - return (actions, Network - { nGraph = graph2 - , nLatchValues = latch3 - , nTime = Dated.next time1 - }) + -- evaluate pulses + ((_, (latchUpdates, outputs)), topologyUpdates, os) + <- runBuildIO (time1, alwaysP) + $ runEvalP pulses + $ evaluatePulses inputs + doit latchUpdates -- update latch values from pulses + doit topologyUpdates -- rearrange graph topology + let actions = OB.inOrder outputs outputs1 -- EvalO actions in proper order + state2 = Network + { nTime = next time1 + , nOutputs = foldr OB.insert outputs1 os + , nAlwaysP = Just alwaysP + } + return (runEvalOs $ map snd actions, state2) -type Result = (EvalL, [(Position, EvalO)]) -type Q = Deps.DepsQueue +runEvalOs :: [EvalO] -> IO () +runEvalOs = sequence_ . map join +{----------------------------------------------------------------------------- + Traversal in dependency order +------------------------------------------------------------------------------} -- | Update all pulses in the graph, starting from a given set of nodes -evaluatePulses :: Graph -> [SomeNode] -> EvalP Result -evaluatePulses Graph { grDeps = deps } roots = - go mempty [] $ insertList roots Deps.emptyQ +evaluatePulses :: [SomeNode] -> EvalP () +evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty where - order = Deps.dOrder deps - - go :: EvalL -> [(Position,EvalO)] -> Q SomeNode -> EvalP Result - go el eo !q1 = {-# SCC go #-} case Deps.minView q1 of - Nothing -> return (el, eo) - Just (a, q2) -> case a of - P p -> evaluateP p >>= \c -> case c of - Deps.Children -> go el eo $ insertList (Deps.children deps a) q2 - Deps.Done -> go el eo q2 - L l -> evaluateL l >>= \x -> go (el `mappend` x) eo q2 - O o -> evaluateO o >>= \x -> go el ((positionO o, x):eo) q2 - - insertList :: [SomeNode] -> Q SomeNode -> Q SomeNode - insertList xs q = {-# SCC insertList #-} - foldl' (\q node -> Deps.insert (level node order) node q) q xs + -- go :: Queue SomeNode -> EvalP () + go r q = {-# SCC go #-} + case ({-# SCC minView #-} Q.minView q) of + Nothing -> return () + Just (node, q) -> do + children <- unwrapEvalP r (evaluateNode node) + q <- insertNodes r children q + go r q +-- | Recalculate a given node and return all children nodes +-- that need to evaluated subsequently. +evaluateNode :: SomeNode -> EvalP [SomeNode] +evaluateNode (P p) = {-# SCC evaluateNodeP #-} do + Pulse{..} <- readRef p + ma <- _evalP + writePulseP _keyP ma + case ma of + Nothing -> return [] + Just _ -> liftIO $ deRefWeaks _childrenP +evaluateNode (L lw) = {-# SCC evaluateNodeL #-} do + time <- askTime + LatchWrite{..} <- readRef lw + mlatch <- liftIO $ deRefWeak _latchLW -- retrieve destination latch + case mlatch of + Nothing -> return () + Just latch -> do + a <- _evalLW -- calculate new latch value + -- liftIO $ Strict.evaluate a -- see Note [LatchStrictness] + rememberLatchUpdate $ -- schedule value to be set later + modify' latch $ \l -> + a `seq` l { _seenL = time, _valueL = a } + return [] +evaluateNode (O o) = {-# SCC evaluateNodeO #-} do + debug "evaluateNode O" + Output{..} <- readRef o + m <- _evalO -- calculate output action + rememberOutput $ (o,m) + return [] +-- | Insert nodes into the queue +-- insertNode :: [SomeNode] -> Queue SomeNode -> EvalP (Queue SomeNode) +insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go + where + go [] q = return q + go (node@(P p):xs) q = do + Pulse{..} <- readRef p + if time <= _seenP + then go xs q -- pulse has already been put into the queue once + else do -- pulse needs to be scheduled for evaluation + put p $! (let p = Pulse{..} in p { _seenP = time }) + go xs (Q.insert _levelP node q) + go (node:xs) q = go xs (Q.insert ground node q) + -- O and L nodes have only one parent, so + -- we can insert them at an arbitrary level diff --git a/src/Reactive/Banana/Prim/Graph.hs b/src/Reactive/Banana/Prim/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Graph.hs @@ -0,0 +1,77 @@ +{----------------------------------------------------------------------------- + reactive-banana + + Implementation of graph-related functionality +------------------------------------------------------------------------------} +module Reactive.Banana.Prim.Graph where + +import Control.Monad +import Data.Functor.Identity +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import Data.Hashable +import Data.Maybe + +{----------------------------------------------------------------------------- + Graphs and topological sorting +------------------------------------------------------------------------------} +data Graph a = Graph + { children :: Map.HashMap a [a] + , parents :: Map.HashMap a [a] + , nodes :: Set.HashSet a + } + +-- | The graph with no edges and no nodes. +emptyGraph :: Graph a +emptyGraph = Graph Map.empty Map.empty Set.empty + +-- | Insert an edge from the first node to the second node into the graph. +insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a +insertEdge (x,y) gr = gr + { children = Map.insertWith (flip (++)) x [y] (children gr) + , parents = Map.insertWith (flip (++)) y [x] (parents gr) + , nodes = Set.insert x $ Set.insert y $ nodes gr + } + +-- | Get all immediate children of a node in a graph. +getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a] +getChildren gr x = maybe [] id . Map.lookup x . children $ gr + +-- | Get all immediate parents of a node in a graph. +getParents :: (Eq a, Hashable a) => Graph a -> a -> [a] +getParents gr x = maybe [] id . Map.lookup x . parents $ gr + +-- | List all nodes such that each parent is listed before all of its children. +listParents :: (Eq a, Hashable a) => Graph a -> [a] +listParents gr = list + where + -- all nodes without children + ancestors = [x | x <- Set.toList $ nodes gr, null (getParents gr x)] + -- all nodes in topological order "parents before children" + list = runIdentity $ dfs' ancestors (Identity . getChildren gr) + +{----------------------------------------------------------------------------- + Graph traversal +------------------------------------------------------------------------------} +-- | Graph represented as map of successors. +type GraphM m a = a -> m [a] + +-- | Depth-first search. List all transitive successors of a node. +-- A node is listed *before* all its successors have been listed. +dfs :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a] +dfs x = dfs' [x] + +-- | Depth-first serach, refined version. +-- INVARIANT: None of the nodes in the initial list have a predecessor. +dfs' :: (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a] +dfs' xs succs = liftM fst $ go xs [] Set.empty + where + go [] ys seen = return (ys, seen) -- all nodes seen + go (x:xs) ys seen + | x `Set.member` seen = go xs ys seen + | otherwise = do + xs' <- succs x + -- visit all children + (ys', seen') <- go xs' ys (Set.insert x seen) + -- list this node as all successors have been seen + go xs (x:ys') seen' diff --git a/src/Reactive/Banana/Prim/IO.hs b/src/Reactive/Banana/Prim/IO.hs --- a/src/Reactive/Banana/Prim/IO.hs +++ b/src/Reactive/Banana/Prim/IO.hs @@ -1,19 +1,19 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} +{-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.IO where +import Control.Monad.IO.Class import Data.Functor -import Data.Unique.Really -import qualified Data.Vault.Strict as Strict -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) +import Data.IORef +import qualified Data.Vault.Lazy as Lazy -import Reactive.Banana.Prim.Combinators (mapP) -import Reactive.Banana.Prim.Dependencies (maybeContinue) -import Reactive.Banana.Prim.Evaluation (step) +import Reactive.Banana.Prim.Combinators (mapP) +import Reactive.Banana.Prim.Evaluation (step) import Reactive.Banana.Prim.Plumbing import Reactive.Banana.Prim.Types +import Reactive.Banana.Prim.Util debug s = id @@ -24,19 +24,22 @@ -- -- Together with 'addHandler', this function can be used to operate with -- pulses as with standard callback-based events. -newInput :: Lazy.Key a -> Build (Pulse a, a -> Step) -newInput key = unsafePerformIO $ do - uid <- newUnique - let pulse = Pulse - { evaluateP = maybeContinue <$> readPulseP pulse - , getValueP = Lazy.lookup key - , uidP = uid - , nameP = "newInput" - } - return $ do - always <- alwaysP - let inputs a = (Lazy.insert key a Lazy.empty, [P pulse, P always]) - return (pulse, step . inputs) +newInput :: Build (Pulse a, a -> Step) +newInput = mdo + always <- alwaysP + key <- liftIO $ Lazy.newKey + pulse <- liftIO $ newRef $ Pulse + { _keyP = key + , _seenP = agesAgo + , _evalP = readPulseP pulse -- get its own value + , _childrenP = [] + , _parentsP = [] + , _levelP = ground + , _nameP = "newInput" + } + -- Also add the alwaysP pulse to the inputs. + let run a = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty) + return (pulse, run) -- | Register a handler to be executed whenever a pulse occurs. -- diff --git a/src/Reactive/Banana/Prim/Order.hs b/src/Reactive/Banana/Prim/Order.hs deleted file mode 100644 --- a/src/Reactive/Banana/Prim/Order.hs +++ /dev/null @@ -1,90 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -{-# LANGUAGE Rank2Types, BangPatterns, RecordWildCards #-} -module Reactive.Banana.Prim.Order ( - -- * Synopsis - -- | Data structure that represents a partial ordering by levels. - - -- * Order - Order, flat, - ensureAbove, recalculateParent, - Level, level, - - ) where - -import Data.Functor -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.Hashable -import qualified Data.IntMap.Strict as IntMap - -type IntMap = IntMap.IntMap -type Map = Map.HashMap -type Set = Set.HashSet - -{----------------------------------------------------------------------------- - Order by levels -------------------------------------------------------------------------------} --- | Each element is assigned a /level/. --- Elements in lower levels come before elements in higher levels. --- There is no order on elements within the same level. -type Order a = Map a Level - --- | FIXME: Level should be an 'Integer' to avoid overflow. --- --- FIXME: The algorithms in this module currently do not try to --- shrink the number or width of levels. -type Level = Integer - --- | The flat order where every element is at 'ground' level. -flat :: Order a -flat = Map.empty - --- | Ground level. -ground :: Level -ground = 0 - --- | Look up the level of an element. Default level is 'ground'. -level :: (Eq a, Hashable a) => a -> Order a -> Level -level x = {-# SCC level #-} maybe ground id . Map.lookup x - --- | Make sure that the first argument is at least one level --- above the second argument. -ensureAbove :: (Eq a, Hashable a) => a -> a -> Order a -> Order a -ensureAbove child parent order = - Map.insertWith max child (level parent order + 1) order - --- | Reassign the parent for a child and recalculate the levels --- for the new parents and grandparents. -recalculateParent :: (Eq a, Hashable a) - => a -- Child. - -> a -- Parent. - -> Graph a -- Query parents of a node. - -> Order a -> Order a -recalculateParent child parent parents order - | d <= 0 = order - | otherwise = concatenate - [ Map.insertWith (+) node (-d) | node <- dfs parent parents ] - order - where - d = level parent order - level child order + 1 - -- level parent - d = level child - 1 - concatenate = foldr (.) id - -{----------------------------------------------------------------------------- - Graph traversal -------------------------------------------------------------------------------} --- | Graph represented as map of successors. -type Graph a = a -> [a] - --- | Depth-first search. List all transitive successors of a node. -dfs :: (Eq a, Hashable a) => a -> Graph a -> [a] -dfs x succs = go [x] Set.empty - where - go [] _ = [] - go (x:xs) seen - | x `Set.member` seen = go xs seen - | otherwise = x : go (ys ++ xs) (Set.insert x seen) - where - ys = succs x diff --git a/src/Reactive/Banana/Prim/OrderedBag.hs b/src/Reactive/Banana/Prim/OrderedBag.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/OrderedBag.hs @@ -0,0 +1,35 @@ +{----------------------------------------------------------------------------- + reactive-banana + + Implementation of a bag whose elements are ordered by arrival time. +------------------------------------------------------------------------------} +{-# LANGUAGE TupleSections #-} +module Reactive.Banana.Prim.OrderedBag where + +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import Data.List +import Data.Maybe +import Data.Ord + +{----------------------------------------------------------------------------- + Ordered Bag +------------------------------------------------------------------------------} +type Position = Integer + +data OrderedBag a = OB !(Map.HashMap a Position) !Position + +empty :: OrderedBag a +empty = OB Map.empty 0 + +-- | Add an element to an ordered bag after all the others. +-- Does nothing if the element is already in the bag. +insert :: (Eq a, Hashable a) => a -> OrderedBag a -> OrderedBag a +insert x (OB xs n) = OB (Map.insertWith (\new old -> old) x n xs) (n+1) + +-- | Reorder a list of elements to appear as they were inserted into the bag. +-- Remove any elements from the list that do not appear in the bag. +inOrder :: (Eq a, Hashable a) => [(a,b)] -> OrderedBag a -> [(a,b)] +inOrder xs (OB bag _) = map snd $ sortBy (comparing fst) $ + mapMaybe (\x -> (,x) <$> Map.lookup (fst x) bag) xs diff --git a/src/Reactive/Banana/Prim/Plumbing.hs b/src/Reactive/Banana/Prim/Plumbing.hs --- a/src/Reactive/Banana/Prim/Plumbing.hs +++ b/src/Reactive/Banana/Prim/Plumbing.hs @@ -1,163 +1,249 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE RecordWildCards, RecursiveDo, BangPatterns #-} module Reactive.Banana.Prim.Plumbing where -import Control.Monad -import Control.Monad.Fix +import Control.Monad (join) +import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS -import qualified Control.Monad.Trans.State as State -import Data.Function +import qualified Control.Monad.Trans.RWSIO as RWS +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.ReaderWriterIO as RW +import Data.Function (on) import Data.Functor -import Data.Functor.Identity -import Data.List +import Data.IORef +import Data.List (sortBy) import Data.Monoid -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Vault.Lazy as Lazy +import System.IO.Unsafe -import Reactive.Banana.Prim.Cached (HasCache(..)) -import qualified Reactive.Banana.Prim.Dated as Dated import qualified Reactive.Banana.Prim.Dependencies as Deps import Reactive.Banana.Prim.Types +import Reactive.Banana.Prim.Util {----------------------------------------------------------------------------- Build primitive pulses and latches ------------------------------------------------------------------------------} -- | Make 'Pulse' from evaluation function newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a) -newPulse name eval = unsafePerformIO $ do +newPulse name eval = liftIO $ do key <- Lazy.newKey - uid <- newUnique - return $ do - let write = maybe (return Deps.Done) ((Deps.Children <$) . writePulseP key) - return $ Pulse - { evaluateP = {-# SCC evaluateP #-} write =<< eval - , getValueP = Lazy.lookup key - , uidP = uid - , nameP = name - } + newRef $ Pulse + { _keyP = key + , _seenP = agesAgo + , _evalP = eval + , _childrenP = [] + , _parentsP = [] + , _levelP = ground + , _nameP = name + } +{- +* 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. + +-} + -- | 'Pulse' that never fires. neverP :: Build (Pulse a) -neverP = unsafePerformIO $ do - uid <- newUnique - return $ return $ Pulse - { evaluateP = return Deps.Done - , getValueP = const Nothing - , uidP = uid - , nameP = "neverP" +neverP = liftIO $ do + key <- Lazy.newKey + newRef $ Pulse + { _keyP = key + , _seenP = agesAgo + , _evalP = return Nothing + , _childrenP = [] + , _parentsP = [] + , _levelP = ground + , _nameP = "neverP" } --- | Make new 'Latch' that can be updated. +-- | Return a 'Latch' that has a constant value +pureL :: a -> Latch a +pureL a = unsafePerformIO $ newRef $ Latch + { _seenL = beginning + , _valueL = a + , _evalL = return a + } + +-- | Make new 'Latch' that can be updated by a 'Pulse' newLatch :: a -> Build (Pulse a -> Build (), Latch a) -newLatch a = unsafePerformIO $ do - key <- Dated.newKey - uid <- newUnique - return $ do - let - write time = maybe mempty (Endo . Dated.update' key time) - latchWrite p = LatchWrite - { evaluateL = {-# SCC evaluateL #-} do - time <- lift $ nTime <$> get - write (Dated.next time) <$> readPulseP p - , uidL = uid +newLatch a = mdo + latch <- liftIO $ newRef $ Latch + { _seenL = beginning + , _valueL = a + , _evalL = do + Latch {..} <- readRef latch + RW.tell _seenL -- indicate timestamp + return _valueL -- indicate value + } + let + err = error "incorrect Latch write" + updateOn p = do + w <- liftIO $ mkWeakRefValue latch latch + lw <- liftIO $ newRef $ LatchWrite + { _evalLW = maybe err id <$> readPulseP p + , _latchLW = w } - updateOn p = P p `addChild` L (latchWrite p) - return - (updateOn, Latch { getValueL = Dated.findWithDefault a key }) + -- writer is alive only as long as the latch is alive + _ <- liftIO $ mkWeakRefValue latch lw + (P p) `addChild` (L lw) + + return (updateOn, latch) --- | Make a new 'Latch' that caches a previous computation -cachedLatch :: Dated.Dated (Dated.Box a) -> Latch a -cachedLatch eval = unsafePerformIO $ do - key <- Dated.newKey - return $ Latch { getValueL = {-# SCC getValueL #-} Dated.cache key eval } +-- | Make a new 'Latch' that caches a previous computation. +cachedLatch :: EvalL a -> Latch a +cachedLatch eval = unsafePerformIO $ mdo + latch <- newRef $ Latch + { _seenL = agesAgo + , _valueL = error "Undefined value of a cached latch." + , _evalL = do + Latch{..} <- liftIO $ readRef latch + -- calculate current value (lazy!) with timestamp + (a,time) <- RW.listen eval + liftIO $ if time <= _seenL + then return _valueL -- return old value + else do -- update value + let _seenL = time + let _valueL = a + a `seq` put latch (Latch {..}) + return a + } + return latch -- | Add a new output that depends on a 'Pulse'. -- -- TODO: Return function to unregister the output again. addOutput :: Pulse EvalO -> Build () -addOutput p = unsafePerformIO $ do - uid <- newUnique - return $ do - pos <- grOutputCount . nGraph <$> get - let o = Output - { evaluateO = {-# SCC evaluateO #-} maybe nop id <$> readPulseP p - , uidO = uid - , positionO = pos - } - modify $ updateGraph $ updateOutputCount $ (+1) - P p `addChild` O o +addOutput p = do + o <- liftIO $ newRef $ Output + { _evalO = maybe (return $ debug "nop") id <$> readPulseP p + } + (P p) `addChild` (O o) + RW.tell $ BuildW (mempty, [o], mempty, mempty) {----------------------------------------------------------------------------- - Build monad - add and delete nodes from the graph + Build monad ------------------------------------------------------------------------------} -runBuildIO :: Network -> BuildIO a -> IO (a, Network) -runBuildIO s1 m = {-# SCC runBuildIO #-} do - (a,s2,liftIOLaters) <- runRWST m () s1 - sequence_ liftIOLaters -- execute late IOs - return (a,s2) +runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output]) +runBuildIO i m = {-# SCC runBuild #-} do + (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m + doit $ liftIOLaters -- execute late IOs + return (a,Action $ Deps.buildDependencies topologyUpdates,os) + where + -- Recursively execute the buildLater calls. + unfold :: BuildW -> BuildIO a -> IO (a, BuildW) + unfold w m = do + (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i + let w' = w <> BuildW (w1,w2,w3,mempty) + w'' <- case later of + Just m -> snd <$> unfold w' m + Nothing -> return w' + return (a,w'') --- Lift a pure Build computation into any monad. --- See note [BuildT] -liftBuild :: Monad m => Build a -> BuildT m a -liftBuild m = RWST $ \r s -> return . runIdentity $ runRWST m r s +buildLater :: Build () -> Build () +buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x) -readLatchB :: Latch a -> Build a -readLatchB latch = state $ \network -> - let (a,v) = Dated.runDated (getValueL latch) (nLatchValues network) - in (Dated.unBox a, network { nLatchValues = v } ) +-- | Pretend to return a value right now, +-- but do not actually calculate it until later. +-- +-- NOTE: Accessing the value before it's written leads to an error. +-- +-- FIXME: Is there a way to have the value calculate on demand? +buildLaterReadNow :: Build a -> Build a +buildLaterReadNow m = do + ref <- liftIO $ newIORef $ + error "buildLaterReadNow: Trying to read before it is written." + buildLater $ m >>= liftIO . writeIORef ref + liftIO $ unsafeInterleaveIO $ readIORef ref +liftBuild :: Build a -> BuildIO a +liftBuild = id + +getTimeB :: Build Time +getTimeB = (\(x,_) -> x) <$> RW.ask + alwaysP :: Build (Pulse ()) -alwaysP = grAlwaysP . nGraph <$> get +alwaysP = (\(_,x) -> x) <$> RW.ask -instance (MonadFix m, Functor m) => HasCache (BuildT m) where - retrieve key = Lazy.lookup key . grCache . nGraph <$> get - write key a = modify $ updateGraph $ updateCache $ Lazy.insert key a +readLatchB :: Latch a -> Build a +readLatchB = liftIO . readLatchIO dependOn :: Pulse child -> Pulse parent -> Build () dependOn child parent = (P parent) `addChild` (P child) -changeParent :: Pulse child -> Pulse parent -> Build () -changeParent child parent = - modify . updateGraph . updateDeps $ Deps.changeParent (P child) (P parent) +keepAlive :: Pulse child -> Pulse parent -> Build () +keepAlive child parent = liftIO $ mkWeakRefValue child parent >> return () addChild :: SomeNode -> SomeNode -> Build () addChild parent child = - modify . updateGraph . updateDeps $ Deps.addChild parent child + RW.tell $ BuildW (Deps.addChild parent child, mempty, mempty, mempty) +changeParent :: Pulse child -> Pulse parent -> Build () +changeParent node parent = + RW.tell $ BuildW (Deps.changeParent node parent, mempty, mempty, mempty) + liftIOLater :: IO () -> Build () -liftIOLater x = tell [x] +liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty) {----------------------------------------------------------------------------- - EvalP - evaluate pulses + EvalL monad ------------------------------------------------------------------------------} -runEvalP :: Lazy.Vault -> EvalP (EvalL, [(Position, EvalO)]) - -> BuildIO (Lazy.Vault, EvalL, EvalO) -runEvalP pulse m = do - ((wl,wo),s) <- State.runStateT m pulse - return (s,wl, sequence_ <$> sequence (sortOutputs wo)) - where - sortOutputs = map snd . sortBy (compare `on` fst) +-- | Evaluate a latch (-computation) at the latest time, +-- but discard timestamp information. +readLatchIO :: Latch a -> IO a +readLatchIO latch = do + Latch{..} <- readRef latch + liftIO $ fst <$> RW.runReaderWriterIOT _evalL () -readLatchP :: Latch a -> EvalP a -readLatchP = {-# SCC readLatchP #-} lift . liftBuild . readLatchB +getValueL :: Latch a -> EvalL a +getValueL latch = do + Latch{..} <- readRef latch + _evalL -readLatchFutureP :: Latch a -> EvalP (Future a) -readLatchFutureP latch = State.state $ \s -> (Dated.unBox <$> getValueL latch,s) +{----------------------------------------------------------------------------- + EvalP monad +------------------------------------------------------------------------------} +runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW) +runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do + (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1 + return ((a,w1), w2) -writePulseP :: Lazy.Key a -> a -> EvalP () -writePulseP key a = {-# SCC writePulseP #-} State.modify $ Lazy.insert key a +liftBuildP :: Build a -> EvalP a +liftBuildP m = RWS.rwsT $ \r2 s -> do + (a,w2) <- RW.runReaderWriterIOT m r2 + return (a,s,(mempty,w2)) +askTime :: EvalP Time +askTime = fst <$> RWS.ask + readPulseP :: Pulse a -> EvalP (Maybe a) -readPulseP pulse = {-# SCC readPulseP #-} getValueP pulse <$> State.get +readPulseP p = do + Pulse{..} <- readRef p + join . Lazy.lookup _keyP <$> RWS.get -liftBuildIOP :: BuildIO a -> EvalP a -liftBuildIOP = lift +writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP () +writePulseP key a = do + s <- RWS.get + RWS.put $ Lazy.insert key a s -liftBuildP :: Build a -> EvalP a -liftBuildP = liftBuildIOP . liftBuild +readLatchP :: Latch a -> EvalP a +readLatchP = liftBuildP . readLatchB +readLatchFutureP :: Latch a -> EvalP (Future a) +readLatchFutureP = return . readLatchIO +rememberLatchUpdate :: IO () -> EvalP () +rememberLatchUpdate x = RWS.tell ((Action x,mempty),mempty) + +rememberOutput :: (Output, EvalO) -> EvalP () +rememberOutput x = RWS.tell ((mempty,[x]),mempty) + +-- worker wrapper to break sharing and support better inlining +unwrapEvalP r m = RWS.run m r +wrapEvalP m = RWS.R m diff --git a/src/Reactive/Banana/Prim/Test.hs b/src/Reactive/Banana/Prim/Test.hs --- a/src/Reactive/Banana/Prim/Test.hs +++ b/src/Reactive/Banana/Prim/Test.hs @@ -28,6 +28,8 @@ let l2 = mapL const l1 return p2 +-- test garbage collection + {----------------------------------------------------------------------------- Space leak tests ------------------------------------------------------------------------------} diff --git a/src/Reactive/Banana/Prim/Types.hs b/src/Reactive/Banana/Prim/Types.hs --- a/src/Reactive/Banana/Prim/Types.hs +++ b/src/Reactive/Banana/Prim/Types.hs @@ -1,194 +1,214 @@ {----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Reactive.Banana.Prim.Types where -import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS.Lazy -import Control.Monad.Trans.State -import Data.Functor.Identity -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set +import Control.Monad.Trans.RWSIO +import Control.Monad.Trans.Reader +import Control.Monad.Trans.ReaderWriterIO +import Data.Functor import Data.Hashable import Data.Monoid -import Data.Unique.Really -import qualified Data.Vault.Lazy as Lazy -import System.IO.Unsafe (unsafePerformIO) - -import Reactive.Banana.Prim.Cached -import qualified Reactive.Banana.Prim.Dated as Dated -import qualified Reactive.Banana.Prim.Dependencies as Deps +import qualified Data.Vault.Lazy as Lazy +import System.IO.Unsafe +import System.Mem.Weak -type Deps = Deps.Deps +import Reactive.Banana.Prim.Graph (Graph) +import Reactive.Banana.Prim.OrderedBag as OB (OrderedBag, empty) +import Reactive.Banana.Prim.Util {----------------------------------------------------------------------------- - Graph + Network ------------------------------------------------------------------------------} --- | A 'Graph' represents the connections between pulses and events. -data Graph = Graph - { grDeps :: Deps SomeNode -- dependency information - , grCache :: Lazy.Vault -- cache for the monad - , grAlwaysP :: Pulse () -- special pulse that always fires - , grOutputCount :: !Position -- ensure declaration order - } -type Position = Integer - -instance Show Graph where show = showDeps . grDeps - -- | A 'Network' represents the state of a pulse/latch network, --- which consists of a 'Graph' and the values of all accumulated latches --- in the network. data Network = Network - { nGraph :: Graph - , nLatchValues :: Dated.Vault - , nTime :: Dated.Time + { nTime :: !Time -- Current time. + , nOutputs :: !(OrderedBag Output) -- Remember outputs to prevent garbage collection. + , nAlwaysP :: !(Maybe (Pulse ())) -- Pulse that always fires. } -instance Show Network where show = show . nGraph +instance Show Network where show = error "instance Show Network not implemented." -type Inputs = (Lazy.Vault, [SomeNode]) +type Inputs = ([SomeNode], Lazy.Vault) type EvalNetwork a = Network -> IO (a, Network) type Step = EvalNetwork (IO ()) --- | Lenses for the 'Graph' and the 'Network' type -updateGraph f = \s -> s { nGraph = f (nGraph s) } -updateLatchValues f = \s -> s { nLatchValues = f (nLatchValues s) } -updateDeps f = \s -> s { grDeps = f (grDeps s) } -updateCache f = \s -> s { grCache = f (grCache s) } -updateOutputCount f = \s -> s { grOutputCount = f (grOutputCount s) } - -emptyGraph :: Graph -emptyGraph = unsafePerformIO $ do - uid <- newUnique - return $ Graph - { grDeps = Deps.empty - , grCache = Lazy.empty - , grAlwaysP = Pulse - { evaluateP = return Deps.Children - , getValueP = const $ Just () - , uidP = uid - , nameP = "alwaysP" - } - , grOutputCount = 0 - } - --- | The 'Network' that contains no pulses or latches. -emptyNetwork :: Network emptyNetwork = Network - { nGraph = emptyGraph - , nLatchValues = Dated.empty - , nTime = Dated.beginning + { nTime = next beginning + , nOutputs = OB.empty + , nAlwaysP = Nothing } --- The 'Build' monad is used to change the graph, for example to --- * add nodes --- * change dependencies --- * add inputs or outputs -type BuildT = RWST () BuildConf Network -type Build = BuildT Identity -type BuildIO = BuildT IO - -type BuildConf = [IO ()] -- liftIOLater +type Build = ReaderWriterIOT BuildR BuildW IO +type BuildR = (Time, Pulse ()) + -- ( current time + -- , pulse that always fires) +newtype BuildW = BuildW (DependencyBuilder, [Output], Action, Maybe (Build ())) + -- reader : current timestamp + -- writer : ( actions that change the network topology + -- , outputs to be added to the network + -- , late IO actions + -- , late build actions + -- ) -{- Note [BuildT] +instance Monoid BuildW where + mempty = BuildW mempty + (BuildW x) `mappend` (BuildW y) = BuildW (x `mappend` y) -It is very convenient to be able to perform some IO functions -while (re)building a network graph. At the same time, -we need a good MonadFix instance to build recursive networks. -These requirements clash, so the solution is to split the types -into a pure variant and IO variant, the former having a good -MonadFix instance while the latter can do arbitrary IO. +type BuildIO = Build --} +type DependencyBuilder = (Endo (Graph SomeNode), [(SomeNode, SomeNode)]) {----------------------------------------------------------------------------- - Pulse and Latch + Synonyms ------------------------------------------------------------------------------} -{- - evaluateL/P - calculates the next value and makes sure that it's cached - getValueL/P - retrieves the current value - uidL/P - used for dependency tracking and evaluation order - nameP - used for debugging --} +-- | Priority used to determine evaluation order for pulses. +type Level = Int -data Pulse a = Pulse - { evaluateP :: EvalP Deps.Continue - , getValueP :: Lazy.Vault -> Maybe a - , uidP :: Unique - , nameP :: String - } +ground :: Level +ground = 0 -data Latch a = Latch - { getValueL :: Future (Dated.Box a) - } +-- | 'IO' actions as a monoid with respect to sequencing. +newtype Action = Action { doit :: IO () } +instance Monoid Action where + mempty = Action $ return () + (Action x) `mappend` (Action y) = Action (x >> y) -data LatchWrite = LatchWrite - { evaluateL :: EvalP EvalL - , uidL :: Unique - } +-- | Lens-like functionality. +data Lens s a = Lens (s -> a) (a -> s -> s) +set (Lens _ set) = set +update (Lens get set) f = \s -> set (f $ get s) s -data Output = Output - { evaluateO :: EvalP EvalO - , uidO :: Unique - , positionO :: Position +{----------------------------------------------------------------------------- + Pulse and Latch +------------------------------------------------------------------------------} +type Pulse a = Ref (Pulse' a) +data Pulse' a = Pulse + { _keyP :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache. + , _seenP :: !Time -- See note [Timestamp]. + , _evalP :: EvalP (Maybe a) -- Calculate current value. + , _childrenP :: [Weak SomeNode] -- Weak references to child nodes. + , _parentsP :: [Weak SomeNode] -- Weak reference to parent nodes. + , _levelP :: !Level -- Priority in evaluation order. + , _nameP :: String -- Name for debugging. } -type EvalP = StateT Lazy.Vault BuildIO - -- state: current pulse values +instance Show (Pulse a) where + show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p) -type Future = Dated.Dated -type EvalL = Endo Dated.Vault -type EvalO = Future (IO ()) +type Latch a = Ref (Latch' a) +data Latch' a = Latch + { _seenL :: !Time -- Timestamp for the current value. + , _valueL :: a -- Current value. + , _evalL :: EvalL a -- Recalculate current latch value. + } +type LatchWrite = Ref LatchWrite' +data LatchWrite' = forall a. LatchWrite + { _evalLW :: EvalP a -- Calculate value to write. + , _latchLW :: Weak (Latch a) -- Destination 'Latch' to write to. + } -nop :: EvalO -nop = return $ return () +type Output = Ref Output' +data Output' = Output + { _evalO :: EvalP EvalO + } +instance Eq Output where (==) = equalRef --- | Existential quantification for dependency tracking data SomeNode = forall a. P (Pulse a) | L LatchWrite | O Output -instance Show SomeNode where show = show . hash +instance Hashable SomeNode where + hashWithSalt s (P x) = hashWithSalt s x + hashWithSalt s (L x) = hashWithSalt s x + hashWithSalt s (O x) = hashWithSalt s x instance Eq SomeNode where - (P x) == (P y) = uidP x == uidP y - (L x) == (L y) = uidL x == uidL y - (O x) == (O y) = uidO x == uidO y - _ == _ = False + (P x) == (P y) = equalRef x y + (L x) == (L y) = equalRef x y + (O x) == (O y) = equalRef x y -uid :: SomeNode -> Unique -uid (P x) = uidP x -uid (L x) = uidL x -uid (O x) = uidO x +{-# INLINE mkWeakNodeValue #-} +mkWeakNodeValue :: SomeNode -> v -> IO (Weak v) +mkWeakNodeValue (P x) = mkWeakRefValue x +mkWeakNodeValue (L x) = mkWeakRefValue x +mkWeakNodeValue (O x) = mkWeakRefValue x -instance Hashable SomeNode where - hashWithSalt s = hashWithSalt s . uid +-- Lenses for various parameters +seenP = Lens _seenP (\a s -> s { _seenP = a }) +seenL = Lens _seenL (\a s -> s { _seenL = a }) +valueL = Lens _valueL (\a s -> s { _valueL = a }) +parentsP = Lens _parentsP (\a s -> s { _parentsP = a }) +childrenP = Lens _childrenP (\a s -> s { _childrenP = a }) +levelP = Lens _levelP (\a s -> s { _levelP = a }) +-- | Evaluation monads. +type EvalPW = (EvalLW, [(Output, EvalO)]) +type EvalLW = Action + +type EvalO = Future (IO ()) +type Future = IO + +-- Note: For efficiency reasons, we unroll the monad transformer stack. +-- type EvalP = RWST () Lazy.Vault EvalPW Build +type EvalP = RWSIOT BuildR (EvalPW,BuildW) Lazy.Vault IO + -- writer : (latch updates, IO action) + -- state : current pulse values + +-- Computation with a timestamp that indicates the last time it was performed. +type EvalL = ReaderWriterIOT () Time IO + {----------------------------------------------------------------------------- Show functions for debugging ------------------------------------------------------------------------------} -showDeps :: Deps SomeNode -> String -showDeps deps = unlines $ - [ detail node ++ - if null children then "" else " -> " ++ unwords (map short children) - | node <- nodes - , let children = Deps.children deps node - ] - where - allChildren = Deps.allChildren deps - nodes = Set.toList . Set.fromList $ - concat [x : xs | (x,xs) <- allChildren] - dictionary = Map.fromList $ zip nodes [1..] - - short node = maybe "X" show $ Map.lookup node dictionary - - detail (P x) = "P " ++ nameP x ++ " " ++ short (P x) - detail (L x) = "L " ++ short (L x) - detail (O x) = "O " ++ short (O x) +printNode :: SomeNode -> IO String +printNode (P p) = _nameP <$> readRef p +printNode (L l) = return "L" +printNode (O o) = return "O" +{----------------------------------------------------------------------------- + Time monoid +------------------------------------------------------------------------------} +-- | A timestamp local to this program run. +-- +-- Useful e.g. for controlling cache validity. +newtype Time = T Integer deriving (Eq, Ord, Show, Read) + +-- | Before the beginning of time. See Note [TimeStamp] +agesAgo :: Time +agesAgo = T (-1) + +beginning :: Time +beginning = T 0 + +next :: Time -> Time +next (T n) = T (n+1) + +instance Monoid Time where + mappend (T x) (T y) = T (max x y) + mempty = beginning + +{----------------------------------------------------------------------------- + Notes +------------------------------------------------------------------------------} +{- Note [Timestamp] + +The time stamp indicates how recent the current value is. + +For Pulse: +During pulse evaluation, a time stamp equal to the current +time indicates that the pulse has already been evaluated in this phase. + +For Latch: +The timestamp indicates the last time at which the latch has been written to. + + agesAgo = The latch has never been written to. + beginning = The latch has been written to before everything starts. + +The second description is ensured by the fact that the network +writes timestamps that begin at time `next beginning`. + +-} diff --git a/src/Reactive/Banana/Prim/Util.hs b/src/Reactive/Banana/Prim/Util.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Prim/Util.hs @@ -0,0 +1,64 @@ +{----------------------------------------------------------------------------- + reactive-banana +------------------------------------------------------------------------------} +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Reactive.Banana.Prim.Util where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Hashable +import Data.IORef +import Data.Maybe (catMaybes) +import Data.Unique.Really +import qualified GHC.Base as GHC +import qualified GHC.IORef as GHC +import qualified GHC.STRef as GHC +import qualified GHC.Weak as GHC +import System.Mem.Weak + +debug :: MonadIO m => String -> m () +-- debug = liftIO . putStrLn +debug _ = return () + +nop :: Monad m => m () +nop = return () + +{----------------------------------------------------------------------------- + IORefs that can be hashed +------------------------------------------------------------------------------} +data Ref a = Ref !(IORef a) !Unique + +instance Hashable (Ref a) where hashWithSalt s (Ref _ u) = hashWithSalt s u + +equalRef :: Ref a -> Ref b -> Bool +equalRef (Ref _ a) (Ref _ b) = a == b + +newRef :: MonadIO m => a -> m (Ref a) +newRef a = liftIO $ liftM2 Ref (newIORef a) newUnique + +readRef :: MonadIO m => Ref a -> m a +readRef ~(Ref ref _) = liftIO $ readIORef ref + +put :: MonadIO m => Ref a -> a -> m () +put ~(Ref ref _) = liftIO . writeIORef ref + +-- | Strictly modify an 'IORef'. +modify' :: MonadIO m => Ref a -> (a -> a) -> m () +modify' ~(Ref ref _) f = liftIO $ readIORef ref >>= \x -> writeIORef ref $! f x + +{----------------------------------------------------------------------------- + Weak pointers +------------------------------------------------------------------------------} +mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value) +mkWeakIORefValueFinalizer r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> + case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) + +mkWeakIORefValue :: IORef a -> value -> IO (Weak value) +mkWeakIORefValue a b = mkWeakIORefValueFinalizer a b (return ()) + +mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value) +mkWeakRefValue (Ref ref _) v = liftIO $ mkWeakIORefValue ref v + +-- | Dereference a list of weak pointers while discarding dead ones. +deRefWeaks :: [Weak v] -> IO [v] +deRefWeaks ws = {-# SCC deRefWeaks #-} fmap catMaybes $ mapM deRefWeak ws diff --git a/src/Reactive/Banana/Switch.hs b/src/Reactive/Banana/Switch.hs --- a/src/Reactive/Banana/Switch.hs +++ b/src/Reactive/Banana/Switch.hs @@ -88,8 +88,14 @@ . Prim.mapE (sequence . map (fmap getIdentity . unM . now)) . unE -- | Obtain the value of the 'Behavior' at moment @t@. +-- +-- NOTE: The value is immediately available for pattern matching. +-- Unfortunately, this means that @valueB@ is unsuitable for use +-- with value recursion in the 'Moment' monad. +-- +-- If you need recursion, please use 'initial' instead. valueB :: Behavior t a -> Moment t a -valueB = M . Prim.initialB . unB +valueB = M . Prim.valueB . unB -- | Dynamically switch between 'Event'. switchE diff --git a/src/Reactive/Banana/Test.hs b/src/Reactive/Banana/Test.hs --- a/src/Reactive/Banana/Test.hs +++ b/src/Reactive/Banana/Test.hs @@ -33,6 +33,7 @@ [ testModelMatch "counter" counter , testModelMatch "double" double , testModelMatch "sharing" sharing + , testModelMatch "unionFilter" unionFilter , testModelMatch "recursive1" recursive1 , testModelMatch "recursive2" recursive2 , testModelMatch "recursive3" recursive3 @@ -43,12 +44,16 @@ , 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 "initialB_recursive1" initialB_recursive1 + -- , testModelMatchM "initialB_recursive2" initialB_recursive2 + , testModelMatchM "trimB_recursive" trimB_recursive , testModelMatchM "dynamic_apply" dynamic_apply , testModelMatchM "switchE1" switchE1 , testModelMatchM "switchB_two" switchB_two ] + , testGroup "Regression tests" + [ testModelMatch "issue79" issue79 + ] -- TODO: -- * algebraic laws -- * larger examples @@ -105,10 +110,16 @@ 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 + +unionFilter e1 = unionWith (+) e2 e3 + where + e3 = fmap (+1) $ filterE even e1 + e2 = fmap (+1) $ filterE odd e1 + recursive1 e1 = e2 where e2 = applyE b e1 @@ -121,7 +132,7 @@ type Dummy = Int --- counter that can be decreased as long as it's >= 0 +-- Counter that can be decreased as long as it's >= 0 . recursive3 :: Event Dummy -> Event Int recursive3 edec = applyE (const <$> bcounter) ecandecrease where @@ -157,38 +168,45 @@ eq = filterApply ((==) <$> result) input neq = filterApply ((/=) <$> result) input --- test accumE vs accumB +-- 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) + x <- valueB (stepper 0 e) return $ x <$ e + +{-- The following tests can no longer work with 'Build' +being a transformer of the 'IO' monad. +See Note [Recursion]. + 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 + return $ observeE $ (valueB =<< mb) <$ e -- = stepper 0 e <@ e + +trimB_recursive e = mdo + let e2 = observeE $ (valueB =<< mb) <$ e + mb <- trimB $ stepper 0 e + return e2 + switchE1 e = do me <- trimE e return $ switchE $ me <$ e @@ -198,3 +216,19 @@ b0 <- mb0 let b = switchB b0 $ (\x -> if odd x then mb1 else mb0) <$> e return $ b <@ e + +{----------------------------------------------------------------------------- + Regression tests +------------------------------------------------------------------------------} +issue79 :: Event Dummy -> Event String +issue79 inputEvent = outputEvent + where + appliedEvent = (\_ _ -> 1) <$> lastValue <@> inputEvent + filteredEvent = filterE (const True) appliedEvent + fmappedEvent = fmap id (filteredEvent) + lastValue = stepper 1 $ fmappedEvent + + outputEvent = unionWith (++) + (const "filtered event" <$> filteredEvent) + (((" and " ++) . show) <$> unionWith (+) appliedEvent fmappedEvent) + diff --git a/src/Reactive/Banana/Test/Plumbing.hs b/src/Reactive/Banana/Test/Plumbing.hs --- a/src/Reactive/Banana/Test/Plumbing.hs +++ b/src/Reactive/Banana/Test/Plumbing.hs @@ -81,7 +81,7 @@ (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) +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) diff --git a/src/Reactive/Banana/Types.hs b/src/Reactive/Banana/Types.hs --- a/src/Reactive/Banana/Types.hs +++ b/src/Reactive/Banana/Types.hs @@ -21,6 +21,7 @@ > type Event t a = [(Time,a)] -} newtype Event t a = E { unE :: Prim.Event [a] } +-- Invariant: The empty list `[]` never occurs as event value. {-| @Behavior t a@ represents a value that varies in time. Think of it as