diff --git a/reactive.cabal b/reactive.cabal --- a/reactive.cabal +++ b/reactive.cabal @@ -1,5 +1,5 @@ Name: reactive -Version: 0.9.1 +Version: 0.9.3 Synopsis: Simple foundation for functional reactive programming Category: reactivity, FRP Description: @@ -14,13 +14,12 @@ . Please see the project wiki page: . - The module documentation pages have links to colorized source code and - to wiki pages where you can read and contribute user comments. Enjoy! - . © 2007-2008 by Conal Elliott; BSD3 license. . - Contributions from: Thomas Davie, Luke Palmer, David Sankel. (Please let me - know if I've forgotten to list you.) + With contributions from: Robin Green, Thomas Davie, Luke Palmer, David + Sankel, Jules Bean, Creighton Hogg, and Chuan-kai Lin. Please let me + know if I've forgotten to list you. + Author: Conal Elliott Maintainer: conal@conal.net Homepage: http://haskell.org/haskellwiki/reactive @@ -33,7 +32,8 @@ Extra-Source-Files: Library Build-Depends: base, old-time, random, QuickCheck < 2.0, - TypeCompose>=0.6.0, vector-space>=0.5, unamb, checkers + TypeCompose>=0.6.0, vector-space>=0.5, + unamb>=0.1.2, checkers >= 0.1.2 -- This library uses the ImpredicativeTypes flag, and it depends -- on vector-space, which needs ghc >= 6.9 if impl(ghc < 6.9) { @@ -70,4 +70,5 @@ FRP.Reactive.Internal.IVar FRP.Reactive.Internal.Serial FRP.Reactive.Internal.TVal + ghc-options: -Wall diff --git a/src/Data/Max.hs b/src/Data/Max.hs --- a/src/Data/Max.hs +++ b/src/Data/Max.hs @@ -17,8 +17,8 @@ import Data.Monoid (Monoid(..)) -import Test.QuickCheck -import Test.QuickCheck.Checkers +import Test.QuickCheck (Arbitrary) +import Test.QuickCheck.Checkers (EqProp) -- | Ordered monoid under 'max'. diff --git a/src/Data/Min.hs b/src/Data/Min.hs --- a/src/Data/Min.hs +++ b/src/Data/Min.hs @@ -16,8 +16,8 @@ import Data.Monoid (Monoid(..)) -import Test.QuickCheck -import Test.QuickCheck.Checkers +import Test.QuickCheck (Arbitrary) +import Test.QuickCheck.Checkers (EqProp) -- | Ordered monoid under 'min'. newtype Min a = Min { getMin :: a } diff --git a/src/FRP/Reactive.hs b/src/FRP/Reactive.hs --- a/src/FRP/Reactive.hs +++ b/src/FRP/Reactive.hs @@ -18,22 +18,23 @@ , EventG, Event , accumE , withTimeE, withTimeE_ - , pairE, scanlE, monoidE - , stateE, stateE_, countE, countE_, diffE + , zipE, scanlE, monoidE + , mealy, mealy_, countE, countE_, diffE , withPrevE, withPrevEWith - , whenE, eitherE + , eitherE -- ** More esoteric , listE, atTimes, atTime, once , firstRestE, firstE, restE, snapRemainderE , withRestE, untilE , splitE, switchE + , justE, filterE -- ** Useful with events. , joinMaybes, filterMP -- * Behaviors , BehaviorG, Behavior , time , stepper, switcher --, select - , snapshotWith, snapshot, snapshot_ + , snapshotWith, snapshot, snapshot_, whenE , accumB , scanlB, monoidB, maybeB, flipFlop, countB , sumB, integral @@ -42,7 +43,7 @@ -- Reactive.Reactive exports reactive values as well. Filter them out. import FRP.Reactive.Reactive hiding - (stepper,switcher,snapshotWith,snapshot,snapshot_,flipFlop,integral) + (stepper,switcher,snapshotWith,snapshot,snapshot_,whenE,flipFlop,integral) import FRP.Reactive.Behavior import FRP.Reactive.VectorSpace () import FRP.Reactive.Num () diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs --- a/src/FRP/Reactive/Behavior.hs +++ b/src/FRP/Reactive/Behavior.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances, CPP #-} {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | @@ -17,20 +18,19 @@ BehaviorG, Behavior , time , stepper, switcher --, select - , snapshotWith, snapshot, snapshot_ - , accumB - , scanlB, monoidB, maybeB, flipFlop, countB + , snapshotWith, snapshot, snapshot_, whenE + , accumB, scanlB, monoidB, maybeB, flipFlop, countB , sumB, integral ) where import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative,pure,(<$>)) +import Control.Applicative (Applicative,(<$>),pure) -- import Control.Monad (join) import Data.VectorSpace import qualified FRP.Reactive.Reactive as R -import FRP.Reactive.Reactive (TimeT, ITime, Event, withTimeE, onceRestE, diffE) +import FRP.Reactive.Reactive (TimeT, ITime, Event, withTimeE, onceRestE, diffE,joinMaybes,result) import FRP.Reactive.Fun import FRP.Reactive.Internal.Behavior @@ -54,7 +54,7 @@ -- | Discretely changing behavior, based on an initial value and a -- new-value event. stepper :: a -> Event a -> Behavior a -stepper = (fmap.fmap) rToB R.stepper +stepper = (result.result) rToB R.stepper -- Suggested by Robin Green: @@ -83,7 +83,7 @@ -- Alternative implementations: -- snapshotWith c e b = uncurry c <$> snapshot e b --- snapshotWith c = (fmap.fmap.fmap) (uncurry c) snapshot +-- snapshotWith c = (result.result.fmap) (uncurry c) snapshot -- | Like 'snapshot' but discarding event data (often @a@ is '()'). snapshot_ :: Event a -> Behavior b -> Event b @@ -91,21 +91,28 @@ -- Alternative implementations -- e `snapshot_` src = snd <$> (e `snapshot` src) --- snapshot_ = (fmap.fmap.fmap) snd snapshot +-- snapshot_ = (result.result.fmap) snd snapshot +-- | Filter an event according to whether a reactive boolean is true. +whenE :: Event a -> Behavior Bool -> Event a +whenE e = joinMaybes . fmap h . snapshot e + where + h (a,True) = Just a + h (_,False) = Nothing + -- | Behavior from an initial value and an updater event. See also -- 'accumE'. accumB :: a -> Event (a -> a) -> Behavior a -accumB = (fmap.fmap) rToB R.accumR +accumB = (result.result) rToB R.accumR -- -- | Like 'scanl' for behaviors. See also 'scanlE'. -- scanlB :: (a -> b -> a) -> a -> Event b -> Behavior a --- scanlB = (fmap.fmap.fmap) rToB R.scanlR +-- scanlB = (result.result.result) rToB R.scanlR -- -- | Accumulate values from a monoid-valued event. Specialization of -- -- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. -- monoidB :: Monoid a => Event a -> Behavior a --- monoidB = fmap rToB R.monoidR +-- monoidB = result rToB R.monoidR ---- The next versions are more continuous: @@ -146,22 +153,22 @@ -- | Like 'sum' for behaviors. sumB :: VectorSpace v => Event v -> Behavior v -sumB = fmap rToB R.sumR +sumB = result rToB R.sumR -- | Start out blank ('Nothing'), latching onto each new @a@, and blanking -- on each @b@. If you just want to latch and not blank, then use -- 'mempty' for the second event. maybeB :: Event a -> Event b -> Behavior (Maybe a) -maybeB = (fmap.fmap) rToB R.maybeR +maybeB = (result.result) rToB R.maybeR -- | Flip-flopping behavior. Turns true whenever first event occurs and -- false whenever the second event occurs. flipFlop :: Event a -> Event b -> Behavior Bool -flipFlop = (fmap.fmap) rToB R.flipFlop +flipFlop = (result.result) rToB R.flipFlop -- | Count occurrences of an event. See also 'countE'. countB :: Num n => Event a -> Behavior n -countB = fmap rToB R.countR +countB = result rToB R.countR -- | Euler integral. integral :: (VectorSpace v, Scalar v ~ TimeT) => @@ -174,3 +181,10 @@ -- -- Early experiments suggest that recursive integration gets stuck. -- Investigate. + + +-- Standard instances for applicative functors + +-- #define APPLICATIVE Behavior +-- #include "Num-inc.hs" + diff --git a/src/FRP/Reactive/Future.hs b/src/FRP/Reactive/Future.hs --- a/src/FRP/Reactive/Future.hs +++ b/src/FRP/Reactive/Future.hs @@ -101,13 +101,6 @@ Future (s,a) `mappend` Future (t,b) = Future (s `min` t, if s <= t then a else b) --- -- A future known never to happen (by construction), i.e., infinite time. --- isNever :: FutureG t a -> Bool --- isNever = isMaxBound . futTime --- where --- isMaxBound (Max MaxBound) = True --- isMaxBound _ = False - -- Consider the following simpler definition: -- -- fa@(Future (s,_)) `mappend` fb@(Future (t,_)) = @@ -124,6 +117,16 @@ -- and '(<=)', so the 'mappend' definition is sub-optimal. In particular, -- 'Improving' has 'minI'. + +-- -- A future known never to happen (by construction), i.e., infinite time. +-- isNever :: FutureG t a -> Bool +-- isNever = isMaxBound . futTime +-- where +-- isMaxBound (Max MaxBound) = True +-- isMaxBound _ = False +-- +-- This function is an abstraction leak. Don't export it to library +-- users. {---------------------------------------------------------- diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs --- a/src/FRP/Reactive/Improving.hs +++ b/src/FRP/Reactive/Improving.hs @@ -17,9 +17,9 @@ ) where -import Data.Function (on) +-- import Data.Function (on) -import Data.Unamb (unamb,asAgree) +import Data.Unamb (unamb,asAgree,parCommute) import Test.QuickCheck.Checkers {---------------------------------------------------------- @@ -34,7 +34,8 @@ exactly a = Imp a (compare a) instance Eq a => Eq (Improving a) where - (==) = (==) `on` exact + -- (==) = (==) `on` exact + (==) = parCommute (\ u v -> u `compareI` exact v == EQ) instance Ord a => Ord (Improving a) where s `min` t = fst (s `minI` t) @@ -42,7 +43,7 @@ -- | Efficient combination of 'min' and '(<=)' minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool) -Imp u uComp `minI` Imp v vComp = (Imp uMinV wComp, uLeqV) +~(Imp u uComp) `minI` ~(Imp v vComp) = (Imp uMinV wComp, uLeqV) where uMinV = if uLeqV then u else v -- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@. @@ -54,7 +55,7 @@ -- | Efficient combination of 'max' and '(>=)' maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool) -Imp u uComp `maxI` Imp v vComp = (Imp uMaxV wComp, uGeqV) +~(Imp u uComp) `maxI` ~(Imp v vComp) = (Imp uMaxV wComp, uGeqV) where uMaxV = if uGeqV then u else v -- u >= v: Try @v `compare` u /= GT@ and @u `compare` v /= LT@. @@ -74,6 +75,8 @@ -- No. Don't implement & export improveMbs. If it's being used, then -- we're not benefitting from this fancy multi-threaded implementation of -- Improving. + +-- TODO: Are the lazy patterns at all helpful? instance (EqProp a) => EqProp (Improving a) where (Imp a _) =-= (Imp b _) = a =-= b diff --git a/src/FRP/Reactive/Internal/Future.hs b/src/FRP/Reactive/Internal/Future.hs --- a/src/FRP/Reactive/Internal/Future.hs +++ b/src/FRP/Reactive/Internal/Future.hs @@ -46,11 +46,6 @@ -- TODO: see if the following definition is really necessary, instead of deriving. --- -- This instance needs to be lazy; automatic deriving doesn't work. --- -- Probably the other instances need this too! TODO (find out). --- instance Functor (FutureG t) where --- fmap f (Future ~(t,x)) = Future (t, f x) - -- The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance -- of 'Max'. diff --git a/src/FRP/Reactive/Internal/Misc.hs b/src/FRP/Reactive/Internal/Misc.hs --- a/src/FRP/Reactive/Internal/Misc.hs +++ b/src/FRP/Reactive/Internal/Misc.hs @@ -10,10 +10,7 @@ -- Misc Reactive internal defs ---------------------------------------------------------------------- -module FRP.Reactive.Internal.Misc - ( - Action, Sink - ) where +module FRP.Reactive.Internal.Misc (Action, Sink) where -- | Convenient alias for dropping parentheses. diff --git a/src/FRP/Reactive/Internal/Reactive.hs b/src/FRP/Reactive/Internal/Reactive.hs --- a/src/FRP/Reactive/Internal/Reactive.hs +++ b/src/FRP/Reactive/Internal/Reactive.hs @@ -132,7 +132,7 @@ -- representation. inREvent :: (EventG s a -> EventG t a) -> (ReactiveG s a -> ReactiveG t a) -inREvent f (a `Stepper` e) = a `Stepper` f e +inREvent f ~(a `Stepper` e) = a `Stepper` f e -- | Apply a unary function inside the future reactive inside a 'Reactive' -- representation. @@ -189,7 +189,7 @@ -- | Run an event in the current thread. Use the given time sink to sync -- time, i.e., to wait for an output time before performing the action. runE :: forall t. Ord t => Sink t -> Sink (EventG t Action) -runE sync (Event (Future (Max bt,r))) = tsync bt (runR sync r) +runE sync ~(Event (Future (Max bt,r))) = tsync bt (runR sync r) where tsync :: AddBounds t -> Sink Action tsync MinBound = id -- no wait diff --git a/src/FRP/Reactive/Internal/TVal.hs b/src/FRP/Reactive/Internal/TVal.hs --- a/src/FRP/Reactive/Internal/TVal.hs +++ b/src/FRP/Reactive/Internal/TVal.hs @@ -14,22 +14,23 @@ module FRP.Reactive.Internal.TVal ( - makeFuture, makeEvent, Fed, MkFed + makeEvent, Fed, MkFed ) where -import Control.Arrow (first) +-- import Control.Arrow (first) import Control.Applicative ((<$>)) import Control.Monad (forever) -import Control.Concurrent (forkIO,yield) +import Control.Concurrent (forkIO,yield,ThreadId) import Control.Concurrent.Chan +-- import System.Mem.Weak (mkWeakPtr,deRefWeak) import System.IO.Unsafe (unsafePerformIO) import Data.Unamb (unamb,assuming) import FRP.Reactive.Improving (Improving(..)) import FRP.Reactive.Future (FutureG,future) -import FRP.Reactive.Reactive (Event,TimeT,ITime) +import FRP.Reactive.Reactive (Event,TimeT) import FRP.Reactive.PrimReactive (futuresE) import FRP.Reactive.Internal.Misc (Sink) @@ -38,42 +39,48 @@ import FRP.Reactive.Internal.IVar -- | A value that becomes defined at some time. 'timeVal' may block if --- forced before the time & value are knowable. 'definedAt' says whether --- the value is defined at (and after) a given time and likely blocks +-- forced before the time & value are knowable. 'undefinedAt' says +-- whether the value is still undefined at a given time and likely blocks -- until the earlier of the query time and the value's actual time. data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool } --- | Make a 'TVal' and a sink to write to it (at most once). -makeTVal :: Clock TimeT -> IO (TVal TimeT a, Sink a) -makeTVal (Clock getT serial) = f <$> newEmptyIVar - where - f v = ( TVal (readIVar v) - (\ t -> unsafePerformIO $ do - sleepPast getT t - do value <- tryReadIVar v - return $ case value of - -- We're past t, so if it's not - -- defined now, it wasn't at t. - Nothing -> False - -- If it became defined before - -- t, then it's defined now. - Just (t',_) -> t' < t) - , \ a -> serial (getT >>= \ t -> writeIVar v (t,a)) - ) +makeTVal :: Clock TimeT -> MkFed (TVal TimeT a) a +makeTVal (Clock getT _) = f <$> newEmptyIVar + where + f v = (TVal (readIVar v) (unsafePerformIO . undefAt), sink) + where + undefAt t = + -- Read v after time t. If it's undefined, then it wasn't defined + -- at t. If it is defined, then see whether it was defined before t. + do -- ser $ putStrLn $ "sleepPast " ++ show t + sleepPast getT t +-- maybe True ((> t) . fst) <$> tryReadIVar v + + value <- tryReadIVar v + case value of + -- We're past t, if it's not defined now, it wasn't at t. + Nothing -> return False + -- If it became defined before t, then it's defined now. + Just (t',_) -> return (t' < t) --- TODO: oops - the definedAt in makeTVal always waits until the given --- time. It could also grab the time and compare with t. Currently that --- comparison is done in tValImp. How can we avoid the redundant test? We --- don't really have to avoid it, since makeTVal isn't exported. + sink a = do t <- getT + writeIVar v (t,a) + -- sink a = getT >>= writeIVar v . flip (,) a + +-- TODO: oops - the undefAt in makeTVal always waits until the given time. +-- It could also grab the time and compare with t. Currently that +-- comparison is done in tValImp. How can we avoid the redundant test? +-- We don't really have to avoid it, since makeTVal isn't exported. + -- | 'TVal' as 'Future' tValFuture :: Ord t => TVal t a -> FutureG (Improving t) a tValFuture v = future (tValImp v) (snd (timeVal v)) -- | 'TVal' as 'Improving' tValImp :: Ord t => TVal t a -> Improving t -tValImp v = Imp ta (\ t -> assuming (not (definedAt v t)) GT - `unamb` (ta `compare` t)) +tValImp v = Imp ta (\ t' -> assuming (not (definedAt v t')) GT + `unamb` (ta `compare` t')) where ta = fst (timeVal v) @@ -83,6 +90,30 @@ -- | Make a 'Fed'. type MkFed a b = IO (Fed a b) + +-- The 'listSink' version of 'makeEvent' is not revealing the finiteness +-- of future times until those times are known exactly. Since many +-- 'Event' operations (including 'mappend' and 'join') check for infinite +-- time (Max MaxBound) before anything else, they'll get stuck immediately. + +-- | Make a new event and a sink that writes to it. Uses the given +-- clock to serialize and time-stamp. +makeEvent :: Clock TimeT -> MkFed (Event a) a +makeEvent clock = + do chanA <- newChan + chanF <- newChan + spin $ do + (tval,snka) <- makeTVal clock + writeChan chanF (tValFuture tval) + readChan chanA >>= snka + futs <- getChanContents chanF + return (futuresE futs, writeChanY chanA) + +-- makeTVal :: Clock TimeT -> MkFed (TVal TimeT a) a + + +{- + -- | Make a connected sink/future pair. The sink may only be written to once. makeFuture :: Clock TimeT -> MkFed (FutureG ITime a) a makeFuture = (fmap.fmap.first) tValFuture makeTVal @@ -92,17 +123,64 @@ makeEvent :: Clock TimeT -> MkFed (Event a) a makeEvent clock = (fmap.first) futuresE (listSink (makeFuture clock)) +-- Turn a single-feedable into a multi-feedable listSink :: MkFed a b -> MkFed [a] b listSink mk = do chanA <- newChan chanB <- newChan - forkIO . forever $ do + spin $ do (a,snk) <- mk - writeChan chanB a - readChan chanA >>= snk - as <- getChanContents chanB - return (as, writeChanY chanA) - where - -- Yield control after each input write. Helps responsiveness - -- tremendously. - writeChanY ch x = writeChan ch x >> yield - -- writeChanY = (fmap.fmap) (>> yield) writeChan + writeChan chanA a + readChan chanB >>= snk + as <- getChanContents chanA + return (as, writeChanY chanB) + +-} + +spin :: IO a -> IO ThreadId +spin = forkIO . forever + + +-- Yield control after channel write. Helps responsiveness +-- tremendously. +writeChanY :: Chan a -> Sink a +writeChanY ch x = writeChan ch x >> yield +-- Equivalently: +-- writeChanY = (fmap.fmap) (>> yield) writeChan + + + + +-- I want to quit gathing input when no one is listening, to eliminate a +-- space leak. Here's my first attempt: + +{- + +listSink :: MkFed a b -> MkFed [a] b +listSink mk = do chanA <- newChan + chanB <- newChan + wchanA <- mkWeakPtr chanA Nothing + let loop = + do mbch <- deRefWeak wchanA + case mbch of + Nothing -> do putStrLn "qutting" + return () + Just ch -> + do putStrLn "something" + (a,snk) <- mk + writeChan ch a + readChan chanB >>= snk + loop + forkIO loop + as <- getChanContents chanA + return (as, writeChanY chanB) + +-} + +-- This attempt fails. The weak reference gets lost almost immediately. +-- My hunch: ghc optimizes away the Chan representation when compiling +-- getChanContents, and just holds onto the read and write ends (mvars), +-- via a technique described at ICFP 07. I don't know how to get a +-- reliable weak reference, without altering Control.Concurrent.Chan. +-- +-- Apparently this problem has popped up before. See +-- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs --- a/src/FRP/Reactive/PrimReactive.hs +++ b/src/FRP/Reactive/PrimReactive.hs @@ -46,11 +46,12 @@ , futuresE, listEG, atTimesG, atTimeG , snapshotWith, accumE, accumR, once , withRestE, untilE + , justE, filterE -- , traceE, traceR -- , mkEvent, mkEventTrace, mkEventShow , eventOcc -- * To be moved elsewhere - , joinMaybes, filterMP + , joinMaybes, filterMP, result -- * To be removed when it gets used somewhere , isMonotoneR -- * Testing @@ -61,8 +62,10 @@ import Data.Monoid import Control.Applicative +import Control.Arrow import Control.Monad import Data.Function (on) +-- import Debug.Trace (trace) -- TODO: eliminate the needs for this stuff. import Control.Concurrent (threadDelay) @@ -151,12 +154,18 @@ -- | Merge two 'Future' streams into one. merge :: Ord t => Binop (FutureG t (ReactiveG t a)) + -- The following two lines seem to be too strict and are causing -- reactive to lock up. I.e. the time argument of one of these -- must have been _|_, so when we pattern match against it, we -- block. +-- +-- On the other hand, they patch a massive space leak in filterE. Perhaps +-- there's an unamb solution. + Future (Max MaxBound,_) `merge` v = v u `merge` Future (Max MaxBound,_) = u + u `merge` v = (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) @@ -170,10 +179,10 @@ -- Define functor instances in terms of each other. instance Functor (EventG t) where - fmap f = inEvent $ (fmap.fmap) f + fmap = inEvent.fmap.fmap instance Functor (ReactiveG t) where - fmap f (a `Stepper` e) = f a `stepper` fmap f e + fmap f ~(a `Stepper` e) = f a `stepper` fmap f e -- standard instance instance Ord t => Applicative (EventG t) where @@ -204,6 +213,7 @@ return a = Event (pure (pure a)) e >>= f = joinE (fmap f e) + -- happy a t b. Same as (a `mappend` b) except takes advantage of knowledge -- that t is a lower bound for the occurences of b. This allows for extra -- laziness. @@ -217,7 +227,6 @@ | t0 <= t = (Event (Future (t0, e `Stepper` (happy ee' t b)))) | otherwise = a `mappend` b - -- Note, joinE should not be called with an infinite list of events that all -- occur at the same time. It can't decide which occurs first. joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a @@ -232,17 +241,25 @@ -- adjustE t0h e `mappend` adjustTopE t0h (joinE ee') adjustTopE :: Ord t => Time t -> EventG t t1 -> EventG t t1 -adjustTopE t0h (Event (Future (tah, r))) = - Event (Future (t0h `max` tah,r)) +adjustTopE t0h = (inEvent.inFuture.first) (max t0h) +-- adjustTopE t0h (Event (Future (tah, r))) = +-- Event (Future (t0h `max` tah,r)) + adjustE :: Ord t => Time t -> EventG t t1 -> EventG t t1 + adjustE _ e@(Event (Future (Max MaxBound, _))) = e adjustE t0h (Event (Future (tah, a `Stepper` e))) = Event (Future (t1h,a `Stepper` adjustE t1h e)) - where - t1h = t0h `max` tah + where + t1h = t0h `max` tah +-- The two-caseness of adjustE prevents the any info from coming out until +-- tah is known to be Max or non-Max. Problem? + +-- Is the MaxBound case really necessary? + -- TODO: add adjustE explanation. What's going on and why t1 in the -- recursive call? David's comment: -- If we have an event [t1, t2] we know t2 >= t1 so (max t t2) == (max (max t t1) t2). @@ -266,6 +283,26 @@ t1h = t0h `max` tah -} +-- From Jules Bean (quicksilver): + +-- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a +-- joinE (Event u) = +-- Event . join $ +-- fmap (\ (e `Stepper` ee) -> +-- let (Event uu) = (e `mappend` joinE ee) in uu) +-- u + +-- plus some fiddling: + +-- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a +-- joinE = inEvent (>>= g) +-- where +-- g ~(e `Stepper` ee) = eFuture (e `mappend` joinE ee) + + +-- These two joinE defs both lock up in my tests. + + instance Ord t => MonadPlus (EventG t) where { mzero = mempty; mplus = mappend } -- Standard instance for Applicative w/ join @@ -274,6 +311,54 @@ r >>= f = joinR (f <$> r) +-- | Pass through the 'Just' occurrences, stripped. Experimental +-- specialization of 'joinMaybes'. +justE :: Ord t => EventG t (Maybe a) -> EventG t a +justE (Event (Future (ta, Just a `Stepper` e'))) = + Event (Future (ta, a `Stepper` justE e')) +justE (Event (Future (ta, Nothing `Stepper` e'))) = + adjustE ta (justE e') + +-- The adjustE lets consumers know that the resulting event occurs no +-- earlier than ta. + +-- | Pass through values satisfying a given predicate. Experimental +-- specialization of 'filterMP'. +filterE :: (Ord t, Show a) => (a -> Bool) -> EventG t a -> EventG t a + +-- filterE p e = joinMaybes (f <$> e) +-- where +-- f a | p a = Just a +-- | otherwise = Nothing + +filterE _ e@(Event (Future (Max MaxBound, _))) = e + +filterE p (Event (Future (ta, a `Stepper` e'))) = h (filterE p e') + where + h | p a = -- trace ("pass " ++ show a) $ + \ e'' -> Event (Future (ta, a `Stepper` e'')) + | otherwise = -- trace ("skip " ++ show a) $ + adjustTopE ta + +-- Or maybe move the adjustTopE to the second filterE + +-- adjustTopE t0h = (inEvent.inFuture.first) (max t0h) + + +-- Laziness problem: no information at all can come out of filterE's +-- result until @p a@ is known. + +-- filterE p ~(Event (Future (ta, a `Stepper` e'))) = +-- Event (Future (ta', r')) +-- where +-- ta' +-- +-- if p a then +-- Event (Future (ta, a `Stepper` filterE p e')) +-- else +-- adjustE ta (filterE p e') + + {-------------------------------------------------------------------- Operations on events and reactive values --------------------------------------------------------------------} @@ -361,7 +446,8 @@ -- | Snapshot a reactive value whenever an event occurs and apply a -- combining function to the event and reactive's values. -snapshotWith :: Ord t => (a -> b -> c) -> EventG t a -> ReactiveG t b -> EventG t c +snapshotWith :: Ord t => + (a -> b -> c) -> EventG t a -> ReactiveG t b -> EventG t c snapshotWith f e r = joinMaybes $ fmap h (e `snap` r) where h (Nothing,_) = Nothing @@ -379,7 +465,7 @@ -- | Just the first occurrence of an event. once :: Ord t => EventG t a -> EventG t a -once = inEvent $ fmap $ pure . rInit +once = (inEvent.fmap) (pure . rInit) -- | Extract a future representing the first occurrence of the event together -- with the event of all occurrences after that one. @@ -389,7 +475,7 @@ -- | Access the remainder with each event occurrence. withRestE :: EventG t a -> EventG t (a, EventG t a) -withRestE = inEvent $ fmap $ +withRestE = (inEvent.fmap) $ \ (a `Stepper` e') -> (a,e') `stepper` withRestE e' @@ -400,6 +486,7 @@ -- | Truncate first event at the given time. untilET :: Ord t => EventG t a -> Time t -> EventG t a + -- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t = -- if ta < t then -- Event (Future (ta, a `Stepper` (e' `untilET` t))) @@ -422,6 +509,8 @@ -- I'm not sure about @<@ vs @<=@ above. + + -- | Sample a reactive value at a sequence of monotonically non-decreasing -- times. Deprecated, because it does not reveal when value is known to -- be repeated in the output. Those values won't be recomputed, but they @@ -484,6 +573,13 @@ -- where -- guarded p x = guard (p x) >> return x + +-- | Apply a given function inside the results of other functions. +-- Equivalent to '(.)', but has a nicer reading when composed +result :: (b -> b') -> ((a -> b) -> (a -> b')) +result = (.) + + {-------------------------------------------------------------------- Tests --------------------------------------------------------------------} @@ -497,9 +593,6 @@ [ ("monotonicity", [ monotonicity2 "<*>" ((<*>) :: ApTy (EventG NumT) T T) --- :: EventG NumT (T -> T) --- -> EventG NumT T --- -> EventG NumT T , monotonicity2 "adjustE" (adjustE :: Time NumT -> EventG NumT NumT diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs --- a/src/FRP/Reactive/Reactive.hs +++ b/src/FRP/Reactive/Reactive.hs @@ -24,11 +24,11 @@ , Event , withTimeE, withTimeE_ , atTime, atTimes, listE - , {-mbsEvent,-} pairE, scanlE, monoidE + , {-mbsEvent,-} zipE, scanlE, monoidE , firstRestE, firstE, restE , remainderR, snapRemainderE, onceRestE , withPrevE, withPrevEWith, withNextE, withNextEWith - , stateE, stateE_, countE, countE_, diffE + , mealy, mealy_, countE, countE_, diffE -- * Reactive values , Reactive , Source @@ -101,7 +101,7 @@ -- | Access occurrence times in an event. Discard the rest. See also -- 'withTimeE'. withTimeE_ :: Event a -> Event TimeT -withTimeE_ = (fmap.fmap) snd withTimeE +withTimeE_ = (result.fmap) snd withTimeE timeT :: Ord t => Time t -> t timeT (Max (NoBound t)) = t @@ -121,9 +121,10 @@ listE = listEG . fmap (first exactly) -- | Generate a pair-valued event, given a pair of initial values and a --- pair of events. See also 'pair' on 'Reactive'. -pairE :: Ord t => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d) -pairE cd cde = cd `accumE` pairEdit cde +-- pair of events. See also 'pair' on 'Reactive'. Not quite a 'zip', +-- because of the initial pair required. +zipE :: Ord t => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d) +zipE cd cde = cd `accumE` pairEdit cde -- | Like 'scanl' for events. scanlE :: Ord t => (a -> b -> a) -> a -> EventG t b -> EventG t a @@ -197,7 +198,7 @@ -- | Pair each event value with the next one one. The second result is -- the next one. withNextE :: Ord t => EventG t a -> EventG t (a,a) -withNextE = (fmap.fmap.fmap) firstE withRestE +withNextE = (result.fmap.second) firstE withRestE -- Alt. def. -- withNextE = fmap (second firstE) . withRestE @@ -208,30 +209,30 @@ -- | State machine, given initial value and transition function. Carries --- along event data. See also 'stateE_'. TODO: better name. -stateE :: Ord t => s -> (s -> s) -> EventG t b -> EventG t (b,s) -stateE s0 f = scanlE h (b0,s0) +-- along event data. See also 'mealy_'. +mealy :: Ord t => s -> (s -> s) -> EventG t b -> EventG t (b,s) +mealy s0 f = scanlE h (b0,s0) where - b0 = error "stateE: no initial value" + b0 = error "mealy: no initial value" h (_,s) b = (b, f s) --- | State machine, given initial value and transition function. See also --- 'stateE'. -stateE_ :: Ord t => s -> (s -> s) -> EventG t b -> EventG t s -stateE_ = (fmap.fmap.fmap.fmap) snd stateE +-- | State machine, given initial value and transition function. +-- Forgetful version of 'mealy'. +mealy_ :: Ord t => s -> (s -> s) -> EventG t b -> EventG t s +mealy_ = (result.result.result.fmap) snd mealy --- stateE_ s0 f e = snd <$> stateE s0 f e +-- mealy_ s0 f e = snd <$> mealy s0 f e -- | Count occurrences of an event, remembering the occurrence values. -- See also 'countE_'. countE :: (Ord t, Num n) => EventG t b -> EventG t (b,n) -countE = stateE 0 (+1) +countE = mealy 0 (+1) -- | Count occurrences of an event, forgetting the occurrence values. See -- also 'countE'. countE_ :: (Ord t, Num n) => EventG t b -> EventG t n -countE_ = (fmap.fmap) snd countE +countE_ = (result.fmap) snd countE -- countE_ e = snd <$> countE e @@ -269,7 +270,7 @@ -- Alternative implementations -- e `snapshot_` src = snd <$> (e `snapshot` src) --- snapshot_ = (fmap.fmap.fmap) snd snapshot +-- snapshot_ = (result.result.fmap) snd snapshot -- | Filter an event according to whether a reactive boolean is true. whenE :: Ord t => EventG t a -> ReactiveG t Bool -> EventG t a