reactive 0.10.5 → 0.10.7
raw patch · 21 files changed
+951/−407 lines, 21 filesdep ~QuickCheckdep ~unamb
Dependency ranges changed: QuickCheck, unamb
Files
- README +0/−2
- reactive.cabal +3/−3
- src/Data/AddBounds.hs +85/−50
- src/FRP/Reactive.hs +1/−1
- src/FRP/Reactive/Behavior.hs +22/−17
- src/FRP/Reactive/Future.hs +25/−8
- src/FRP/Reactive/Improving.hs +49/−26
- src/FRP/Reactive/Internal/Behavior.hs +1/−1
- src/FRP/Reactive/Internal/Future.hs +27/−14
- src/FRP/Reactive/Internal/IVar.hs +2/−1
- src/FRP/Reactive/Internal/Reactive.hs +71/−30
- src/FRP/Reactive/Internal/TVal.hs +73/−35
- src/FRP/Reactive/Internal/Timing.hs +26/−15
- src/FRP/Reactive/LegacyAdapters.hs +3/−2
- src/FRP/Reactive/Num-inc.hs +10/−5
- src/FRP/Reactive/PrimReactive.hs +256/−144
- src/FRP/Reactive/Reactive.hs +72/−47
- src/Test/Integ.hs +42/−6
- src/Test/Merge.hs +89/−0
- src/Test/Reactive.hs +2/−0
- src/Test/SimpleFilter.hs +92/−0
README view
@@ -13,8 +13,6 @@ The theory and implementation of Reactive are described in the paper "Simply efficient functional reactivity" [4]. -Please share any comments & suggestions on the discussion (talk) page [1].- Note that cabal[5], version 1.4.0.1 or greater is required for installation. You can configure, build, and install all in the usual way with Cabal
reactive.cabal view
@@ -1,5 +1,5 @@ Name: reactive-Version: 0.10.5+Version: 0.10.7 Synopsis: Simple foundation for functional reactive programming Category: reactivity, FRP Description:@@ -31,9 +31,9 @@ Build-Type: Simple Extra-Source-Files: Library- Build-Depends: base, old-time, random, QuickCheck < 2.0,+ Build-Depends: base, old-time, random, QuickCheck, TypeCompose>=0.6.3, vector-space>=0.5,- unamb>=0.1.2, checkers >= 0.1.3,+ unamb>=0.1.5, checkers >= 0.1.3, category-extras >= 0.53.5, Stream -- This library uses the ImpredicativeTypes flag, and it depends -- on vector-space, which needs ghc >= 6.9
src/Data/AddBounds.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- |@@ -15,8 +16,10 @@ import Control.Applicative (pure,(<$>)) --- import Data.Unamb (unamb)+import Data.Unamb (unamb) +import Data.AffineSpace+ -- Testing import Test.QuickCheck import Test.QuickCheck.Checkers@@ -44,63 +47,83 @@ -- (NoBound a) `min` (NoBound b) can return partial information from -- a `min` b while the default implementation cannot. -instance Ord a => Ord (AddBounds a) where- MinBound <= _ = True- NoBound _ <= MinBound = False- NoBound a <= NoBound b = a <= b- NoBound _ <= MaxBound = True- MaxBound <= MaxBound = True- MaxBound <= _ = False -- given previous +-- instance Ord a => Ord (AddBounds a) where+-- MinBound <= _ = True+-- NoBound _ <= MinBound = False+-- NoBound a <= NoBound b = a <= b+-- NoBound _ <= MaxBound = True+-- MaxBound <= MaxBound = True+-- MaxBound <= _ = False -- given previous - MinBound `min` _ = MinBound- _ `min` MinBound = MinBound- NoBound a `min` NoBound b = NoBound (a `min` b)- u `min` MaxBound = u- MaxBound `min` v = v+-- MinBound `min` _ = MinBound+-- _ `min` MinBound = MinBound+-- NoBound a `min` NoBound b = NoBound (a `min` b)+-- u `min` MaxBound = u+-- MaxBound `min` v = v - MinBound `max` v = v- u `max` MinBound = u- NoBound a `max` NoBound b = NoBound (a `max` b)- _ `max` MaxBound = MaxBound- MaxBound `max` _ = MaxBound+-- MinBound `max` v = v+-- u `max` MinBound = u+-- NoBound a `max` NoBound b = NoBound (a `max` b)+-- _ `max` MaxBound = MaxBound+-- MaxBound `max` _ = MaxBound --- Richard Smith (lilac) contributed this code for lazier methods.--- MaxBound `max` undefined can return full information while the default--- implementation cannot. And likewise undefined `max` MaxBound.+-- The definition above is too strict for some uses. Here's a parallel+-- version. --- instance Ord a => Ord (AddBounds a) where--- a <= b = c1 a b `unamb` c2 a b--- where c1 MinBound _ = True--- c1 _ MinBound = False--- c1 (NoBound a') (NoBound b') = a' < b'--- c1 MaxBound (NoBound _) = False--- c1 _ _ = undefined--- c2 _ MaxBound = True--- c2 _ _ = undefined--- a `min` b = c1 a b `unamb` c2 a b--- where c1 MinBound _ = MinBound--- c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'--- c1 (NoBound _ ) MaxBound = a--- c1 MaxBound (NoBound _ ) = b--- c1 MaxBound MaxBound = MaxBound--- c1 _ _ = undefined--- c2 _ MinBound = MinBound--- c2 _ _ = undefined--- a `max` b = c1 a b `unamb` c2 a b--- where c1 MaxBound _ = MaxBound--- c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'--- c1 (NoBound _ ) MinBound = a--- c1 MinBound (NoBound _ ) = b--- c1 MinBound MinBound = MinBound--- c1 _ _ = undefined--- c2 _ MaxBound = MaxBound--- c2 _ _ = undefined --- This second instance has a strange delays in a reactive-fieldtrip--- program. My mouse click isn't responded to until I move the mouse.+-- Alternatively, make a non-parallel definition here and use 'pmin'+-- instead of 'min' where I want. +-- General recipe for Ord methods: use unamb to try two strategies. The+-- first one, "justB", only examines b. The second one first examines+-- only examines a and then examines both. I take care that the two+-- strategies handle disjoint inputs. I could instead let the second+-- strategy handle the first one redundantly, being careful that they+-- agree.++-- This instance is very like the one Richard Smith (lilac) constructed.+-- It fixes a couple of small bugs and follows a style that helps me see+-- that I'm covering all of the cases with the evaluation order I want.++instance Ord a => Ord (AddBounds a) where+ a <= b = justB b `unamb` (a <=* b)+ where+ justB MaxBound = True+ justB _ = undefined++ MinBound <=* _ = True+ _ <=* MinBound = False+ NoBound u <=* NoBound v = u <= v+ MaxBound <=* NoBound _ = False+ _ <=* MaxBound = undefined++ a `min` b = justB b `unamb` (a `min'` b)+ where+ justB MinBound = MinBound+ justB MaxBound = a+ justB (NoBound _) = undefined+ + MinBound `min'` _ = MinBound+ MaxBound `min'` v = v+ NoBound u `min'` NoBound v = NoBound (u `min` v)+ _ `min'` MinBound = undefined+ _ `min'` MaxBound = undefined++ a `max` b = justB b `unamb` (a `max'` b)+ where+ justB MaxBound = MaxBound+ justB MinBound = a+ justB (NoBound _) = undefined+ + MaxBound `max'` _ = MaxBound+ MinBound `max'` v = v+ NoBound u `max'` NoBound v = NoBound (u `max` v)+ _ `max'` MaxBound = undefined+ _ `max'` MinBound = undefined++ instance Arbitrary a => Arbitrary (AddBounds a) where arbitrary = frequency [ (1 ,pure MinBound) , (10, NoBound <$> arbitrary)@@ -112,3 +135,15 @@ instance (EqProp a, Eq a) => EqProp (AddBounds a) where NoBound a =-= NoBound b = a =-= b u =-= v = u `eq` v+++-- Hm. I'm dissatisfied with this next instance. I'd like to tweak my+-- type definitions to eliminate these partial definitions.++instance AffineSpace t => AffineSpace (AddBounds t) where+ type Diff (AddBounds t) = Diff t+ NoBound u .-. NoBound v = u .-. v+ -- I don't know what to do here+ _ .-. _ = error "(.-.) on AddBounds: only defined on NoBound args"+ NoBound u .+^ v = NoBound (u .+^ v)+ _ .+^ _ = error "(.+^) on AddBounds: only defined on NoBound args"
src/FRP/Reactive.hs view
@@ -22,12 +22,12 @@ , mealy, mealy_, countE, countE_, diffE , withPrevE, withPrevEWith , eitherE+ , justE, filterE -- ** More esoteric , listE, atTimes, atTime, once , firstRestE, firstE, restE, snapRemainderE , withRestE, untilE , splitE, switchE- , justE, filterE -- ** Useful with events. , joinMaybes, filterMP -- * Behaviors
src/FRP/Reactive/Behavior.hs view
@@ -34,19 +34,24 @@ import Control.Compose ((:.)(..)) import Data.VectorSpace+import Data.AffineSpace import qualified FRP.Reactive.Reactive as R import FRP.Reactive.Reactive- ( TimeT, EventG, ReactiveG+ ( ImpBounds, TimeT, EventG, ReactiveG , withTimeE,onceRestE,diffE,joinMaybes,result) import FRP.Reactive.Fun-import FRP.Reactive.Improving+-- import FRP.Reactive.Improving import FRP.Reactive.Internal.Behavior -type EventI t = EventG (Improving t)-type ReactiveI t = ReactiveG (Improving t)-type BehaviorI t = BehaviorG (Improving t) t+-- type EventI t = EventG (Improving t)+-- type ReactiveI t = ReactiveG (Improving t)+-- type BehaviorI t = BehaviorG (Improving t) t +type EventI t = EventG (ImpBounds t)+type ReactiveI t = ReactiveG (ImpBounds t)+type BehaviorI t = BehaviorG (ImpBounds t) t+ -- | Time-specialized behaviors. -- Note: The signatures of all of the behavior functions can be generalized. Is -- the interface generality worth the complexity?@@ -59,7 +64,7 @@ -- | The identity generalized behavior. Has value @t@ at time @t@. -- -- > time :: Behavior TimeT-time :: Ord t => BehaviorI t t+time :: (Ord t) => BehaviorI t t time = beh (pure (fun id)) -- Turn a reactive value into a discretly changing behavior.@@ -89,7 +94,7 @@ -- | Switch between behaviors. -- -- > switcher :: Behavior a -> Event (Behavior a) -> Behavior a-switcher :: (Ord tr) =>+switcher :: (Ord tr, Bounded tr) => BehaviorG tr tf a -> EventG tr (BehaviorG tr tf a) -> BehaviorG tr tf a@@ -100,7 +105,7 @@ -- arguments and results. -- -- > snapshotWith :: (a -> b -> c) -> Behavior b -> Event a -> Event c-snapshotWith :: Ord t =>+snapshotWith :: (Ord t) => (a -> b -> c) -> BehaviorI t b -> EventI t a -> EventI t c snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e)@@ -120,7 +125,7 @@ -- results. -- -- > snapshot :: Behavior b -> Event a -> Event (a,b)-snapshot :: Ord t => BehaviorI t b -> EventI t a -> EventI t (a,b)+snapshot :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t (a,b) snapshot = snapshotWith (,) -- TODO: tweak withTimeE so that 'snapshotWith' and 'snapshot' can have@@ -134,7 +139,7 @@ -- | Like 'snapshot' but discarding event data (often @a@ is '()'). -- -- > snapshot_ :: Behavior b -> Event a -> Event b-snapshot_ :: Ord t => BehaviorI t b -> EventI t a -> EventI t b+snapshot_ :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t b snapshot_ = snapshotWith (flip const) -- Alternative implementations@@ -144,7 +149,7 @@ -- | Filter an event according to whether a reactive boolean is true. -- -- > whenE :: Behavior Bool -> Event a -> Event a-whenE :: Ord t => BehaviorI t Bool -> EventI t a -> EventI t a+whenE :: (Ord t) => BehaviorI t Bool -> EventI t a -> EventI t a b `whenE` e = joinMaybes (h <$> (b `snapshot` e)) where h (a,True) = Just a@@ -197,7 +202,7 @@ -- TODO: generalize scanlB's type -scanlB :: forall a b tr tf. Ord tr =>+scanlB :: forall a b tr tf. (Ord tr, Bounded tr) => (b -> BehaviorG tr tf a -> BehaviorG tr tf a) -> BehaviorG tr tf a -> EventG tr b -> BehaviorG tr tf a@@ -213,7 +218,7 @@ -- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. -- -- > monoidB :: Monoid a => Event (Behavior a) -> Behavior a-monoidB :: (Ord tr, Monoid a) => EventG tr (BehaviorG tr tf a)+monoidB :: (Ord tr, Bounded tr, Monoid a) => EventG tr (BehaviorG tr tf a) -> BehaviorG tr tf a monoidB = scanlB mappend mempty @@ -228,7 +233,7 @@ -- 'mempty' for the second event. -- -- > maybeB :: Event a -> Event b -> Behavior (Maybe a)-maybeB :: Ord t =>+maybeB :: (Ord t) => EventI t a -> EventI t b -> BehaviorI t (Maybe a) maybeB = (result.result) rToB R.maybeR @@ -236,7 +241,7 @@ -- false whenever the second event occurs. -- -- > flipFlop :: Event a -> Event b -> Behavior Bool-flipFlop :: Ord t => EventI t a -> EventI t b -> BehaviorI t Bool+flipFlop :: (Ord t) => EventI t a -> EventI t b -> BehaviorI t Bool flipFlop = (result.result) rToB R.flipFlop -- | Count occurrences of an event. See also 'countE'.@@ -249,11 +254,11 @@ -- -- > integral :: (VectorSpace v, Scalar v ~ TimeT) => -- > Event () -> Behavior v -> Behavior v-integral :: (Scalar v ~ t, Ord t, VectorSpace v, Num t) =>+integral :: (VectorSpace v, AffineSpace t, Scalar v ~ Diff t, Ord t) => EventI t a -> BehaviorI t v -> BehaviorI t v integral t b = sumB (snapshotWith (*^) b (diffE (time `snapshot_` t))) --- Yow! That's a mouth full!+-- TODO: This integral definition is piecewise-constant. Change to piecewise-linear. -- TODO: find out whether this integral works recursively. If not, then
src/FRP/Reactive/Future.hs view
@@ -44,11 +44,11 @@ -- values/. ---------------------------------------------------------------------- -module FRP.Reactive.Future +module FRP.Reactive.Future ( -- * Time & futures Time, ftime- , FutureG(..), inFuture, inFuture2, futTime, futVal, future+ , FutureG(..), isNeverF, inFuture, inFuture2, futTime, futVal, future , withTimeF -- * Tests , batch@@ -57,7 +57,7 @@ import Data.Monoid (Monoid(..)) import Data.Max-import Data.AddBounds+-- import Data.AddBounds import FRP.Reactive.Internal.Future -- Testing@@ -71,14 +71,22 @@ -- | Make a finite time ftime :: t -> Time t-ftime = Max . NoBound+ftime = Max -- FutureG representation in Internal.Future -instance (EqProp t, Eq t, EqProp a) => EqProp (FutureG t a) where- Future (Max MaxBound,_) =-= Future (Max MaxBound,_) = property True+instance (Bounded t, Eq t, EqProp t, EqProp a) => EqProp (FutureG t a) where+ u =-= v | isNeverF u && isNeverF v = property True Future a =-= Future b = a =-= b +-- I'd rather say:+-- +-- instance (Bounded t, EqProp t, EqProp a) => EqProp (FutureG t a) where+-- Future a =-= Future b =+-- (fst a =-= maxBound && fst b =-= maxBound) .|. a =-= b+-- +-- However, I don't know how to define disjunction on QuickCheck properties.+ -- | A future's time futTime :: FutureG t a -> Time t futTime = fst . unFuture@@ -102,7 +110,7 @@ -- below. For one thing, the current instance makes Future a monoid but -- unFuture not be a monoid morphism. -instance Ord t => Monoid (FutureG t a) where+instance (Ord t, Bounded t) => Monoid (FutureG t a) where mempty = Future (maxBound, error "Future mempty: it'll never happen, buddy") -- Pick the earlier future. Future (s,a) `mappend` Future (t,b) =@@ -145,6 +153,11 @@ newtype TimeInfo t = TimeInfo (Maybe t) deriving EqProp +instance Bounded t => Bounded (TimeInfo t) where+ minBound = TimeInfo (Just minBound)+ maxBound = TimeInfo Nothing++ -- A time at a given instant can be some unknown time in the future unknownTimeInFuture :: TimeInfo a unknownTimeInFuture = TimeInfo Nothing@@ -198,10 +211,14 @@ ] ) where- laziness :: NumT -> T -> Property+ laziness :: BoundedT -> T -> Property laziness t a = (uf `mappend` uf) `mappend` kf =-= kf where uf = unknownFuture kf = knownFuture knownFuture = future (knownTimeInPast t) a unknownFuture = future unknownTimeInFuture (error "cannot retrieve value at unknown time at the future")+++-- Move to checkers+type BoundedT = Int
src/FRP/Reactive/Improving.hs view
@@ -21,9 +21,9 @@ import Data.Function (on) import Text.Show.Functions ()-import Control.Applicative (pure,(<$>))+import Control.Applicative (pure,(<$>),liftA2) -import Data.Unamb (unamb,asAgree,parCommute)+import Data.Unamb (unamb,parCommute,pmin,pmax) import Test.QuickCheck hiding (evaluate) -- import Test.QuickCheck.Instances@@ -52,14 +52,14 @@ before x = Imp undefined comp where comp y | x <= y = LT- | otherwise = undefined+ | otherwise = error "before: comparing before" -- | A value known to be @> x@. after :: Ord a => a -> Improving a after x = Imp undefined comp where comp y | x >= y = GT- | otherwise = undefined+ | otherwise = error "after: comparing after" instance Eq a => Eq (Improving a) where@@ -68,15 +68,15 @@ -- exactly. (==) = parCommute (\ u v -> u `compareI` exact v == EQ) +-- TODO: experiment with these two versions of (==). The 'parCommute' one+-- can return 'False' sooner than the simpler def, but I doubt it'll+-- return 'True' any sooner. + instance Ord a => Ord (Improving a) where min = (result.result) fst minI (<=) = (result.result) snd minI max = (result.result) fst maxI --- instance Ord a => Ord (Improving a) where--- s `min` t = fst (s `minI` t)--- s <= t = snd (s `minI` t)- -- | 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)@@ -84,14 +84,17 @@ uMinV = if uLeqV then u else v -- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@. uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT)- -- (u `min` v) `compare` t: Try comparing according to whether u <= v,- -- or go with either answer if they agree, e.g., if both say GT.- wComp t = minComp `unamb` (uCt `asAgree` vCt)- where- minComp = if uLeqV then uCt else vCt- uCt = uComp t- vCt = vComp t+ wComp = liftA2 pmin uComp vComp +-- -- (u `min` v) `compare` t: Try comparing according to whether u <= v,+-- -- or go with either answer if they agree, e.g., if both say GT.+-- -- And say GT if either comp says LT.+-- wComp t = (uCt `asAgree` LT `unamb` vCt `asAgree` LT) -- LT cases+-- `unamb` (uCt `min` vCt) -- EQ and GT case+-- where+-- uCt = uComp t+-- vCt = vComp t+ -- | 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)@@ -99,14 +102,19 @@ uMaxV = if uGeqV then u else v -- u >= v: Try @v `compare` u /= GT@ and @u `compare` v /= LT@. uGeqV = (vComp u /= GT) `unamb` (uComp v /= LT)- -- (u `max` v) `compare` t: Try comparing according to whether u >= v,- -- or go with either answer if they agree, e.g., if both say LT.- wComp t = maxComp `unamb` (uCt `asAgree` vCt)- where- maxComp = if uGeqV then uCt else vCt- uCt = uComp t- vCt = vComp t+ wComp = liftA2 pmax uComp vComp +-- -- (u `max` v) `compare` t: Try comparing according to whether u >= v,+-- -- or go with either answer if they agree, e.g., if both say LT.+-- -- And say LT if either comp says GT.+-- wComp t = (uCt `asAgree` GT `unamb` vCt `asAgree` GT) -- GT cases+-- `unamb` (uCt `max` vCt) -- EQ and LT case+-- where+-- uCt = uComp t+-- vCt = vComp t++-- TODO: reconsider these wComp tests and look for a smaller set.+ -- TODO: factor commonality out of 'minI' and 'maxI' or combine into -- a single function. @@ -118,10 +126,25 @@ -- advantage of a knowably infinite value, which I use in a lot of -- optimization, including filter/join. -instance Bounded (Improving a) where- minBound = error "minBound not defined on Improving"- maxBound = Imp (error "exact maxBound")- (const GT)+-- instance Bounded (Improving a) where+-- minBound = error "minBound not defined on Improving"+-- maxBound = Imp (error "exact maxBound")+-- (const GT)++instance (Ord a, Bounded a) => Bounded (Improving a) where+ minBound = exactly minBound+ maxBound = exactly maxBound++-- Hack: use 0 as lower bound+-- No, this one won't work, because I'll need to extract the exact value+-- in order to compare with maxBound++-- instance (Ord a, Num a) => Bounded (Improving a) where+-- minBound = exactly 0+-- maxBound = -- exactly maxBound+-- Imp (error "Improving maxBound evaluated")+-- (const GT)+ -- TODO: consider 'undefined' instead 'error', for 'unamb'. However, we -- lose valuable information if the 'undefined' gets forced with no
src/FRP/Reactive/Internal/Behavior.hs view
@@ -66,7 +66,7 @@ { mempty = pure mempty; mappend = liftA2 mappend } -- Standard 'Zip' for an 'Applicative'-instance Ord tr => Zip (BehaviorG tr tf) where zip = liftA2 (,)+instance (Ord tr, Bounded tr) => Zip (BehaviorG tr tf) where zip = liftA2 (,) -- Standard 'Unzip' for a 'Functor' instance Unzip (BehaviorG tr tf) where {fsts = fmap fst; snds = fmap snd}
src/FRP/Reactive/Internal/Future.hs view
@@ -16,7 +16,7 @@ ( -- * Time & futures Time- , FutureG(..), inFuture, inFuture2+ , FutureG(..), isNeverF, inFuture, inFuture2 , runF ) where @@ -29,23 +29,41 @@ import FRP.Reactive.Internal.Misc (Sink) import Data.Max-import Data.AddBounds import Data.PairMonad () --- | Time used in futures. The parameter @t@ can be any @Ord@ type. The--- added bounds represent -Infinity and +Infinity. Pure values have time--- minBound (-Infinity), while never-occurring futures have time maxBound--- (+Infinity).-type Time t = Max (AddBounds t)+-- | Time used in futures. The parameter @t@ can be any @Ord@ and+-- @Bounded@ type. Pure values have time 'minBound', while+-- never-occurring futures have time 'maxBound.'+-- type Time t = Max (AddBounds t) +type Time = Max + -- | A future value of type @a@ with time type @t@. Simply a -- time\/value pair. Particularly useful with time types that have -- non-flat structure. newtype FutureG t a = Future { unFuture :: (Time t, a) }- deriving (Functor, Applicative, Monad, Copointed, Comonad, Show, Arbitrary)+ deriving (Functor, Applicative, Monad, Copointed, Comonad {-, Show-}, Arbitrary) +isNeverF :: (Bounded t, Eq t) => FutureG t t1 -> Bool+isNeverF (Future (t,_)) = t == maxBound++instance (Eq t, Eq a, Bounded t) => Eq (FutureG t a) where+ Future a == Future b =+ (fst a == maxBound && fst b == maxBound) || a == b++-- When I drop @AddBounds@, I use @maxBound@ as infinity/never. I'm+-- uncomfortable with this choice, however. Consider a small type like+-- @Bool@ for @t@.+++instance (Show t, Show a, Eq t, Bounded t) => Show (FutureG t a) where+-- show (Future (Max t, a)) | t == maxBound = "<never>"+-- | otherwise = "<" ++ show t ++ "," ++ show a ++ ">"+ show u | isNeverF u = "<never>"+ show (Future (Max t, a)) = "<" ++ show t ++ "," ++ show a ++ ">"+ -- The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance -- of 'Max'. @@ -64,9 +82,4 @@ -- | Run a future in the current thread. Use the given time sink to sync -- time, i.e., to wait for an output time before performing the action. runF :: Ord t => Sink t -> FutureG t (IO a) -> IO a-runF sync (Future (Max t,io)) = tsync t >> io- where- tsync MinBound = putStrLn "runE: skipping MinBound"- tsync (NoBound t') = sync t'- tsync MaxBound = error "runE: infinite wait"-+runF sync (Future (Max t,io)) = sync t >> io
src/FRP/Reactive/Internal/IVar.hs view
@@ -29,7 +29,8 @@ -- | Returns the value in the IVar. The *value* will block -- until the variable becomes filled. readIVar :: IVar a -> a-readIVar (IVar v) = unsafePerformIO $ readMVar v+readIVar (IVar v) = unsafePerformIO $ do -- putStrLn "readIVar"+ readMVar v -- | Returns Nothing if the IVar has no value yet, otherwise -- returns the value.
src/FRP/Reactive/Internal/Reactive.hs view
@@ -21,19 +21,19 @@ module FRP.Reactive.Internal.Reactive (- EventG(..), inEvent, inEvent2, eFutures+ EventG(..), isNeverE, inEvent, inEvent2, eFutures , ReactiveG(..), inREvent, inFutR , runE, runR, forkE, forkR ) where -import Data.List (intersperse)+-- import Data.List (intersperse) import Control.Concurrent (forkIO,ThreadId) import FRP.Reactive.Internal.Misc import FRP.Reactive.Internal.Future import Data.Max-import Data.AddBounds+-- import Data.AddBounds -- | Events. Semantically: time-ordered list of future values. -- Instances: @@ -145,40 +145,66 @@ Showing values (exposing rep) --------------------------------------------------------------------} +isNeverE :: (Bounded t, Eq t) => EventG t a -> Bool+isNeverE = isNeverF . eFuture+ -- | Make the event into a list of futures-eFutures :: EventG t a -> [FutureG t a]-eFutures (Event (Future (Max MaxBound,_))) = []+eFutures :: (Bounded t, Eq t) => EventG t a -> [FutureG t a]+eFutures e | isNeverE e = [] eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e -- TODO: redefine 'eFutures' as an unfold +-- TODO: does this isNeverE interfere with laziness? Does it need an unamb? -- Show a future sFuture :: (Show t, Show a) => FutureG t a -> String-sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")"-sFuture (Future (Max MaxBound,_)) = "(infty,_)"-sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")"+sFuture = show . unFuture +-- sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")"+-- sFuture (Future (Max MaxBound,_)) = "(infty,_)"+-- sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")"+ -- TODO: Better re-use in sFuture. -- Truncated show sFutures :: (Show t, Show a) => [FutureG t a] -> String-sFutures fs =- let maxleng = 20- a = (intersperse "->" . map sFuture) fs- inf = length (take maxleng a) == maxleng- in- if not inf then concat a- else concat (take maxleng a) ++ "..." +-- sFutures = show++-- This next implementation blocks all output until far future occurrences+-- are detected, which causes problems for debugging. I like the "...",+-- so look for another implementation.++-- sFutures fs =+-- let maxleng = 20+-- a = (intersperse "->" . map sFuture) fs+-- inf = length (take maxleng a) == maxleng+-- in+-- if not inf then concat a+-- else concat (take maxleng a) ++ "..."++-- This version uses a lazier intersperse+-- sFutures = take 100 . concat . intersperse' "->" . map sFuture++-- The following version adds "..." in case of truncation.++sFutures fs = leading early ++ trailing late+ where+ (early,late) = splitAt 20 fs+ leading = concat . intersperse' "->" . map sFuture+ trailing [] = ""+ trailing _ = "-> ..."+ + -- TODO: clean up sFutures def: use intercalate, concat before trimming, -- and define&use a general function for truncating and adding "...". -- Test. -instance (Show a, Show b) => Show (EventG a b) where- show = sFutures . eFutures+instance (Eq t, Bounded t, Show t, Show a) => Show (EventG t a) where+ show = ("Event: " ++) . sFutures . eFutures -instance (Show x, Show y) => Show (ReactiveG x y) where+instance (Eq t, Bounded t, Show t, Show a) => Show (ReactiveG t a) where show (x `Stepper` e) = show x ++ " `Stepper` " ++ show e @@ -188,19 +214,17 @@ -- | 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)- where- tsync :: AddBounds t -> Sink Action- tsync MinBound = id -- no wait- tsync (NoBound t) = (sync t >>) -- wait- tsync MaxBound = const (return ()) -- finished!+runE :: forall t. (Ord t, Bounded t) => Sink t -> Sink (EventG t Action)+runE sync ~(Event (Future (Max t,r)))+ | t == maxBound = return () -- finished!+ | otherwise = sync t >> runR sync r --- TODO: I'm not sure about the MaxBound case. We could instead just wait--- forever (cheaply). Try out this terminating definition instead.+-- In most cases, the value of t won't be known ahead of time, so just+-- evaluating t will do the necessary waiting. + -- | Run an event in a new thread, using the given time sink to sync time.-forkE :: Ord t => Sink t -> EventG t Action -> IO ThreadId+forkE :: (Ord t, Bounded t) => Sink t -> EventG t Action -> IO ThreadId forkE = (fmap.fmap) forkIO runE -- TODO: Revisit this tsync definition. For instance, maybe the MaxBound@@ -208,10 +232,27 @@ -- | Run a reactive value in the current thread, using the given time sink -- to sync time.-runR :: Ord t => Sink t -> Sink (ReactiveG t Action)+runR :: (Bounded t, Ord t) => Sink t -> Sink (ReactiveG t Action) runR sync (act `Stepper` e) = act >> runE sync e -- | Run a reactive value in a new thread, using the given time sink to -- sync time. The initial action happens in the current thread.-forkR :: Ord t => Sink t -> ReactiveG t Action -> IO ThreadId+forkR :: (Ord t, Bounded t) => Sink t -> ReactiveG t Action -> IO ThreadId forkR = (fmap.fmap) forkIO runR++-----++-- intersperse :: a -> [a] -> [a]+-- intersperse _ [] = []+-- intersperse _ [x] = [x]+-- intersperse sep (x:xs) = x : sep : intersperse sep xs++-- Lazier intersperse++intersperse' :: a -> [a] -> [a]+intersperse' _ [] = []+intersperse' sep (x:xs) = x : continue xs+ where+ continue [] = []+ continue xs' = sep : intersperse' sep xs'+
src/FRP/Reactive/Internal/TVal.hs view
@@ -13,14 +13,11 @@ ---------------------------------------------------------------------- module FRP.Reactive.Internal.TVal- (- makeEvent,- ) where-+ ((:-->), (:+->), makeEvent) where -import Control.Applicative ((<$>),liftA2)--- import Control.Monad (when)-import Control.Concurrent (forkIO,yield) -- ,ThreadId+import Control.Applicative ((<$>)) -- ,liftA2+-- import Control.Monad (forever)+import Control.Concurrent (forkIO,yield) -- , ThreadId -- import Control.Concurrent.Chan hiding (getChanContents) import FRP.Reactive.Internal.Chan@@ -28,10 +25,11 @@ --import System.Mem.Weak (mkWeakPtr,deRefWeak) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) -import Data.Stream (Stream(..))+import Data.Stream (Stream(..)) -- ,streamToList import Data.Unamb (unamb,assuming) +import Data.AddBounds import FRP.Reactive.Improving (Improving(..)) import FRP.Reactive.Future (FutureG,future) import FRP.Reactive.Reactive (Event,TimeT,ITime)@@ -41,6 +39,7 @@ import FRP.Reactive.Internal.Clock import FRP.Reactive.Internal.Timing (sleepPast) import FRP.Reactive.Internal.IVar+-- import FRP.Reactive.Internal.Reactive (isNeverE) -- | An @a@ that's fed by a @b@ type b :--> a = (Sink b, a)@@ -55,14 +54,16 @@ data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool } makeTVal :: Clock TimeT -> a :+-> TVal TimeT a-makeTVal (Clock getT _) = f <$> newIVar+makeTVal (Clock getT _) = do -- putStrLn "makeTVal"+ f <$> newIVar where f v = (sink, TVal (readIVar v) (unsafePerformIO . undefAt)) 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+ do -- putStrLn $ "undefAt " ++ show t+ -- ser $ putStrLn $ "sleepPast " ++ show t sleepPast getT t -- maybe False ((< t) . fst) <$> tryReadIVar v @@ -73,7 +74,8 @@ -- If it became defined before t, then it's defined now. Just (t',_) -> return (t' < t) - sink a = do t <- getT+ sink a = do -- putStrLn "sink"+ t <- getT writeIVar v (t,a) -- sink a = getT >>= writeIVar v . flip (,) a@@ -84,22 +86,24 @@ -- 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 :: Ord t => TVal t a -> FutureG (Improving (AddBounds 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+tValImp :: Ord t => TVal t a -> Improving (AddBounds t)+tValImp v = Imp ta (\ t' -> assuming (not (definedAt' v t')) GT `unamb` (ta `compare` t')) where- ta = fst (timeVal v)+ ta = NoBound (fst (timeVal v)) +definedAt' :: TVal t a -> AddBounds t -> Bool+definedAt' _ MinBound = False+definedAt' tval (NoBound t) = definedAt tval t+definedAt' _ MaxBound = True --- 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.+-- definedAt' _ _ = error "definedAt': non-NoBound" + -- -- | Make a new event and a sink that writes to it. Uses the given -- -- clock to serialize and time-stamp. -- makeEvent :: Clock TimeT -> a :+-> Event a@@ -107,6 +111,8 @@ -- do chanA <- newChan -- chanF <- newChan -- spin $ do+-- -- Get the skeleton tval written out immediately. Details will+-- -- be added -- (tval,snka) <- makeTVal clock -- writeChan chanF (tValFuture tval) -- readChan chanA >>= snka@@ -122,21 +128,41 @@ -- | Make a new event and a sink that writes to it. Uses the given -- clock to serialize and time-stamp.-makeEvent :: Clock TimeT -> (a :+-> Event a)+makeEvent :: Clock TimeT -> forall a. Show a => (a :+-> Event a) makeEvent clock = (fmap.fmap) futureStreamE (listSink (makeFuture clock)) +-- makeEvent clock =+-- do (snk,s) <- listSink (makeFuture clock)+-- let e = futureStreamE s+-- putStrLn $ "isNeverE e == " ++ show (isNeverE e)+-- -- putStrLn $ "makeEvent: e == " ++ show e+-- return (snk, e)+ + -- Turn a single-feedable into a multi-feedable-listSink :: (b :+-> a) -> (b :+-> Stream a) +-- listSink :: (b :+-> a) -> (b :+-> [a]) -- listSink mk = do chanA <- newChan -- chanB <- newChan -- spin $ do--- (a,snk) <- mk+-- (snk,a) <- mk+-- -- putStrLn "writing input" -- writeChan chanA a -- readChan chanB >>= snk -- as <- getChanContents chanA--- return (as, writeChanY chanB)--- +-- return (writeChanY chanB, as)++listSink :: Show a => (b :+-> a) -> (b :+-> Stream a)++-- listSink mk = do chanA <- newChan+-- chanB <- newChan+-- spin $ do+-- (snk,a) <- mk+-- -- putStrLn "writing input"+-- writeChan chanA a+-- readChan chanB >>= snk+-- as <- getChanStream chanA+-- return (writeChanY chanB, as) -- spin :: IO a -> IO ThreadId -- spin = forkIO . forever @@ -183,7 +209,8 @@ -- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer -listSink mk = do chanA <- newChan+listSink mk = do -- putStrLn "listSink"+ chanA <- newChan chanB <- newChan -- let loop = do (snk,a) <- mk@@ -208,14 +235,20 @@ do -- putStrLn "bailing" return () Just writeA ->- do (snk,a) <- mk+ do -- putStrLn "writing to weak channel"+ (snk,a) <- mk writeA a- -- yield+ -- putStrLn "wrote"+ yield readChan chanB >>= snk loop forkIO loop as <- getChanStream chanA++ -- debugging. defeats freeing.+ -- forkIO $ print $ streamToList as+ return (writeChanY chanB, as) @@ -227,12 +260,17 @@ -- hoping to get some extra laziness by using irrefutable 'Cons' pattern -- when consuming the stream. getChanStream :: Chan a -> IO (Stream a)-getChanStream ch = unsafeInterleaveIO $- liftA2 Cons (readChan ch) (getChanStream ch) --- getChanStream ch--- = unsafeInterleaveIO (do--- x <- readChan ch--- xs <- getChanStream ch--- return (Cons x xs)--- )+-- getChanStream ch = unsafeInterleaveIO $+-- liftA2 Cons (readChan ch) (getChanStream ch)++getChanStream ch+ = unsafeInterleaveIO (do+ x <- readChan ch+ xs <- getChanStream ch+ return (Cons x xs)+ )+++{-+-}
src/FRP/Reactive/Internal/Timing.hs view
@@ -12,7 +12,9 @@ -- ---------------------------------------------------------------------- -module FRP.Reactive.Internal.Timing (adaptE,mkUpdater,sleepPast) where+module FRP.Reactive.Internal.Timing+ (adaptE,mkUpdater,sleepPast)+ where import Data.Monoid (mempty) import Control.Applicative ((<$>))@@ -24,7 +26,9 @@ -- For IO monoid import Control.Instances () -import FRP.Reactive.Reactive (TimeT,Event)+import Data.AddBounds++import FRP.Reactive.Reactive (exactNB,TimeT,Event) import FRP.Reactive.Improving (Improving,exact) import FRP.Reactive.Behavior (Behavior) @@ -39,7 +43,7 @@ -- | Execute an action-valued event. adaptE :: Sink (Event Action) adaptE e = do clock <- makeClock- runE (sleepPast (cGetTime clock) . exact) e+ runE (sleepPast (cGetTime clock) . exactNB) e -- | If a sample variable is full, act on the contents, leaving it empty.@@ -60,7 +64,7 @@ -- The plan: Stash new phases (time functions) in a sample variable as -- they arise. Every minPeriod, check the sample var for a new value. do actSVar <- newEmptySampleVar- _ <- forkR (sleepPast getT . exact)+ _ <- forkR (sleepPast' getT . exact) (writeSampleVar' actSVar <$> unb acts) tfunRef <- newIORef (noSink :: Sink TimeT) return $@@ -85,17 +89,24 @@ sleep :: Sink TimeT sleep = threadDelay . ceiling . (1.0e6 *) +-- sleep = threadDelay . ceiling . (1.0e6 *)+ -- | Sleep past a given time sleepPast :: IO TimeT -> Sink TimeT-sleepPast getT !target = loop- where+sleepPast getT !target = -- Snooze until strictly after the target.- loop = do -- The strict evaluation of target is essential here.- -- (See bang pattern.) Otherwise, the next line will grab a- -- time before a possibly long block, and then sleep much- -- longer than necessary.- now <- getT- -- putStrLn $ "sleep loop: now == " ++ show now- -- ++ ", target == " ++ show target- unless (now > target) $- sleep (target-now) -- >> loop+ do -- The strict evaluation of target is essential here.+ -- (See bang pattern.) Otherwise, the next line will grab a+ -- time before a possibly long block, and then sleep much+ -- longer than necessary.+ now <- getT+-- putStrLn $ "sleepPast: now == " ++ show now+-- ++ ", target == " ++ show target+ unless (now > target) $+ sleep (target-now) -- >> loop++-- | Variant of 'sleepPast', taking a possibly-infinite time+sleepPast' :: IO TimeT -> Sink (AddBounds TimeT)+sleepPast' _ MinBound = return ()+sleepPast' getT (NoBound target) = sleepPast getT target+sleepPast' _ MaxBound = error "sleepPast MaxBound. Expected??"
src/FRP/Reactive/LegacyAdapters.hs view
@@ -15,11 +15,12 @@ module FRP.Reactive.LegacyAdapters ( Sink, Action , Clock, makeClock, cGetTime- , adaptE, makeEvent, mkUpdater+ , adaptE, mkUpdater+ , module FRP.Reactive.Internal.TVal ) where import FRP.Reactive.Internal.Misc (Sink,Action) import FRP.Reactive.Internal.Clock (Clock,makeClock,cGetTime)-import FRP.Reactive.Internal.TVal (makeEvent)+import FRP.Reactive.Internal.TVal import FRP.Reactive.Internal.Timing (adaptE,mkUpdater)
src/FRP/Reactive/Num-inc.hs view
@@ -13,6 +13,11 @@ -- "Control.Applicative". ---------------------------------------------------------------------- +-- This module still needs some think work. It now assumes that Eq, Ord,+-- Enum, and Show are undefined, which is not a good assumption. For+-- instance, Maybe.++ noOv :: String -> String -> a noOv ty meth = error $ meth ++ ": No overloading for " ++ ty @@ -28,7 +33,7 @@ min = liftA2 min max = liftA2 max -instance Enum a => Enum (APPLICATIVE a) where+instance Enum b => Enum (APPLICATIVE b) where succ = fmap succ pred = fmap pred toEnum = pure . toEnum@@ -51,10 +56,10 @@ abs = fmap abs signum = fmap signum -instance (Num a, Ord a) => Real (APPLICATIVE a) where+instance (Num b, Ord b) => Real (APPLICATIVE b) where toRational = noFun "toRational" -instance Integral a => Integral (APPLICATIVE a) where+instance Integral b => Integral (APPLICATIVE b) where quot = liftA2 quot rem = liftA2 rem div = liftA2 div@@ -83,14 +88,14 @@ atanh = fmap atanh acosh = fmap acosh -instance RealFrac a => RealFrac (APPLICATIVE a) where+instance RealFrac b => RealFrac (APPLICATIVE b) where properFraction = noFun "properFraction" truncate = noFun "truncate" round = noFun "round" ceiling = noFun "ceiling" floor = noFun "floor" -instance RealFloat a => RealFloat (APPLICATIVE a) where+instance RealFloat b => RealFloat (APPLICATIVE b) where floatRadix = noFun "floatRadix" floatDigits = noFun "floatDigits" floatRange = noFun "floatRange"
src/FRP/Reactive/PrimReactive.hs view
@@ -44,7 +44,7 @@ -- * Operations on events and reactive values , stepper, switcher, withTimeGE, withTimeGR , futuresE, futureStreamE, listEG, atTimesG, atTimeG- , snap, snapshotWith, accumE, accumR, once+ , snapshotWith, accumE, accumR, once , withRestE, untilE , justE, filterE -- , traceE, traceR@@ -55,27 +55,29 @@ -- * To be removed when it gets used somewhere , isMonotoneR -- * Testing- , batch, infE+ , batch, infE, monoid_E+ -- * Temporary exports, while debugging+ -- , snap, merge ) where import Prelude hiding (zip,zipWith) import Data.Monoid import Control.Applicative-import Control.Arrow+import Control.Arrow (first) import Control.Monad import Data.Function (on) -- import Debug.Trace (trace) -import Data.Stream (Stream(..))--import Control.Comonad- -- TODO: eliminate the needs for this stuff. import Control.Concurrent (threadDelay) import Control.Exception (evaluate) import System.IO.Unsafe +import Data.Stream (Stream(..))++import Control.Comonad+ import Test.QuickCheck hiding (evaluate) import Test.QuickCheck.Instances import Test.QuickCheck.Checkers@@ -87,10 +89,12 @@ import Data.Zip import Control.Instances () -- Monoid (IO ()) -import Data.Unamb (race) -import Data.Max-import Data.AddBounds+import Data.Unamb (unamb, assuming)+import Data.Unamb (race) -- eliminate++-- import Data.Max+-- import Data.AddBounds import FRP.Reactive.Future hiding (batch) import FRP.Reactive.Internal.Reactive @@ -101,40 +105,43 @@ -- Bogus EqProp instance. TODO: replace with a random equality test, such -- that the collection of all generated tests covers equality. -instance (Eq a, Eq b, EqProp a, EqProp b) => EqProp (EventG a b) where+instance (Bounded t, Eq t, Eq a, EqProp t, EqProp a) => EqProp (EventG t a) where a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b) where f = take 20 . eFutures -arbitraryE :: (Num t, Ord t, Arbitrary t, Arbitrary u) => Gen (EventG t u)+-- TODO: work less and reach further per (=-=).++arbitraryE :: (Num t, Ord t, Bounded t, Arbitrary t, Arbitrary u) => Gen (EventG t u) arbitraryE = frequency - [ (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)- , (4, liftA futuresE futureList)+ [ -- (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)+ (4, liftA futuresE futureList) ] where- earliestFuture = Future . (,) (Max MinBound)- addStart = (:).earliestFuture- futureList = frequency [(10, futureListFinite), (1,futureListInf)]+ -- earliestFuture = Future . (,) (Max MinBound)+ -- addStart = (:).earliestFuture+ futureList = futureListFinite+ -- frequency [(10, futureListFinite), (1,futureListInf)] futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary- futureListInf =- liftA2 (zipWith future) (resize 10 nondecreasingInf)- (infiniteList arbitrary)+-- futureListInf =+-- liftA2 (zipWith future) (resize 10 nondecreasingInf)+-- (infiniteList arbitrary) -instance (Arbitrary t, Ord t, Num t, Arbitrary a) => Arbitrary (EventG t a) where+instance (Arbitrary t, Ord t, Bounded t, Num t, Arbitrary a) => Arbitrary (EventG t a) where arbitrary = arbitraryE coarbitrary = coarbitrary . eFuture ---- -- Arbitrary works just like pairs:-instance (Arbitrary t, Arbitrary a, Num t, Ord t) => Arbitrary (ReactiveG t a) where+instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where arbitrary = liftA2 Stepper arbitrary arbitrary coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a -instance Ord t => Model (ReactiveG t a) (t -> a) where+instance (Ord t, Bounded t) => Model (ReactiveG t a) (t -> a) where model = rat -instance (Ord t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)+instance (Ord t, Bounded t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a) where (=-=) = (=-=) `on` model @@ -147,17 +154,17 @@ Instances --------------------------------------------------------------------} -instance Ord t => Monoid (EventG t a) where+instance (Ord t, Bounded t) => Monoid (EventG t a) where mempty = Event mempty mappend = inEvent2 merge -- Standard instance for Applicative of Monoid-instance (Ord t, Monoid a) => Monoid (ReactiveG t a) where+instance (Ord t, Bounded t, Monoid a) => Monoid (ReactiveG t a) where mempty = pure mempty mappend = liftA2 mappend --- | Merge two 'Future' streams into one.-merge :: Ord t => Binop (FutureG t (ReactiveG t a))+-- | Merge two 'Future' reactives into one.+merge :: (Ord t, Bounded 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@@ -167,12 +174,22 @@ -- 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 = +u `merge` v =+ assuming (isNeverF u) v `unamb`+ assuming (isNeverF v) u `unamb` (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) +-- TODO: redefine via parIdentity from Data.Unamb++-- u `merge` v | isNever u = v+-- | isNever v = u++-- Future (Max MaxBound,_) `merge` v = v+-- u `merge` Future (Max MaxBound,_) = u++-- u `merge` v = +-- (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)+ -- What's going on in this 'merge' definition? Try two different -- future paths. If u arrives before v (or simultaneously), then -- begin as u begins and then merge v with the rest of u. Otherwise,@@ -189,21 +206,22 @@ fmap f ~(a `Stepper` e) = f a `stepper` fmap f e -- standard instance-instance Ord t => Applicative (EventG t) where+instance (Ord t, Bounded t) => Applicative (EventG t) where pure = return- _ <*> (Event (Future (Max MaxBound,_))) = mempty- x <*> y = x `ap` y+ (<*>) = ap+-- _ <*> (Event (Future (Max MaxBound,_))) = mempty+-- x <*> y = x `ap` y -- standard instance-instance Ord t => Alternative (EventG t) where+instance (Ord t, Bounded t) => Alternative (EventG t) where { empty = mempty; (<|>) = mappend } -instance Ord t => Zip (ReactiveG t) where+instance (Ord t, Bounded t) => Zip (ReactiveG t) where -- zip :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b) (c `Stepper` ce) `zip` (d `Stepper` de) = (c,d) `accumR` pairEdit (ce,de) -instance Ord t => Applicative (ReactiveG t) where+instance (Ord t, Bounded t) => Applicative (ReactiveG t) where pure a = a `stepper` mempty -- Standard definition. See 'Zip'. rf <*> rx = zipWith ($) rf rx@@ -213,11 +231,66 @@ -- when the argument or function changes. -instance Ord t => Monad (EventG t) where+instance (Ord t, Bounded t) => Monad (EventG t) where return a = Event (pure (pure a)) e >>= f = joinE (fmap f e) +-- 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, Bounded t) => EventG t (EventG t a) -> EventG t a++joinE (Event u) = Event (u >>= eFuture . g)+ where + g (e `Stepper` ee) = e `mappend` joinE ee++-- joinE = inEvent (>>= eFuture . g)+-- where +-- g (e `Stepper` ee) = e `mappend` joinE ee+++-- | Experimental specialization of 'joinMaybes'.+justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a+justE ~(Event (Future (t, mb `Stepper` e'))) =+ assuming (t == maxBound) mempty `unamb`+ (inEvent.inFuture.first) (max t) $+ case mb of+ Nothing -> justE e'+ Just a -> Event (Future (t, a `Stepper` justE e'))+++-- This definition is much more efficient than the following.++-- justE = (>>= maybe mzero return)++-- On the other hand, this simpler definition inserts the necessary max+-- applications so that we needn't find a Just in order to have a lower bound.++-- TODO: find and fix the inefficiency.++++++-- | Experimental specialization of 'filterMP'.+filterE :: (Ord t, Bounded t) => (a -> Bool) -> EventG t a -> EventG t a+filterE p m = justE (liftM f m)+ where+ f a | p a = Just a+ | otherwise = Nothing+++{-+ -- 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.@@ -225,6 +298,12 @@ Time t -> EventG t a -> EventG t a+happy a t b =+ assuming (isNeverE a) b `unamb`+ assuming (isNeverF b) a `unamb`+ happy' a t b ...++ happy a (Max MaxBound) _ = a happy (Event (Future (Max MaxBound, _))) _ b = b happy a@(Event (Future (t0, e `Stepper` ee'))) t b @@ -239,19 +318,32 @@ = adjustE t0h e joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _))))))) = happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee'))+-} +{-+-- 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+joinE (Event (Future (t0h, e `Stepper` ee'))) =+ assuming (t0h == maxBound) mempty $+ adjustE t0h (e `mappend` joinE ee')++-- TODO: revisit this def.++ -- Original Version: -- joinE (Event (Future (t0h, e `Stepper` ee'))) = -- adjustE t0h e `mappend` adjustTopE t0h (joinE ee') -adjustTopE :: Ord t => Time t -> EventG t t1 -> EventG t t1-adjustTopE t0h = (inEvent.inFuture.first) (max t0h)+adjustTopE :: (Ord t, Bounded 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) -adjustE :: Ord t => Time t -> EventG t t1 -> EventG t t1+adjustTopE t0h ~(Event (Future (tah, r))) =+ Event (Future (t0h `max` tah,r)) +adjustE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1+ adjustE _ e@(Event (Future (Max MaxBound, _))) = e adjustE t0h (Event (Future (tah, a `Stepper` e))) =@@ -259,6 +351,8 @@ 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? @@ -277,7 +371,7 @@ -- reactive to lock up. Need to verify correctness. (Does lock up with -- the mappend optimization that eliminates a space/time leak.) {--joinE :: Ord t => EventG t (EventG t a) -> EventG t a+joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a joinE (Event (Future (t0h, ~(e `Stepper` ee')))) = adjustE t0h (e `mappend` joinE ee') @@ -287,37 +381,31 @@ 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 }+instance (Ord t, Bounded t) => MonadPlus (EventG t) where+ { mzero = mempty; mplus = mappend } -- Standard instance for Applicative w/ join-instance Ord t => Monad (ReactiveG t) where+instance (Ord t, Bounded t) => Monad (ReactiveG t) where return = pure r >>= f = joinR (f <$> r) +-- -- Temporary+-- justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a+-- justE = joinMaybes++-- filterE :: (Ord t, Bounded t, Show a) => (a -> Bool) -> EventG t a -> EventG t a+-- filterE = filterMP++{-+ -- | Pass through the 'Just' occurrences, stripped. Experimental -- specialization of 'joinMaybes'.-justE :: Ord t => EventG t (Maybe a) -> EventG t a+justE :: (Ord t, Bounded 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'))) =@@ -337,13 +425,26 @@ 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+filterE p (Event (Future (ta, a `Stepper` e'))) =+ adjustTopE ta $+ if p a then+ Event (Future (ta, a `Stepper` filterE p e'))+ else filterE p e'+-} +-- The adjustTopE ta guarantees a lower bound even before we've looked at a.++-- filterE p (Event (Future (ta, a `Stepper` e')))+-- | p a = Event (Future (ta, a `Stepper` filterE p e'))+-- | otherwise = adjustTopE ta (filterE p 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)@@ -376,15 +477,15 @@ -- -- -- -- Oops: breaks the semantic abstraction of 'Reactive' as a step -- function.--- rToE :: Ord t => ReactiveG t a -> EventG t a+-- rToE :: (Ord t, Bounded t) => ReactiveG t a -> EventG t a -- rToE (a `Stepper` e) = pure a `mappend` e -- | Switch between reactive values.-switcher :: Ord t => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a+switcher :: (Ord t, Bounded t) => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a r `switcher` e = join (r `stepper` e) -- | Reactive 'join' (equivalent to 'join' but slightly more efficient, I think)-joinR :: Ord t => ReactiveG t (ReactiveG t a) -> ReactiveG t a+joinR :: (Ord t, Bounded t) => ReactiveG t (ReactiveG t a) -> ReactiveG t a joinR ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u where@@ -412,11 +513,11 @@ -- | Convert a temporally monotonic list of futures to an event. See also -- the specialization 'listE'-listEG :: Ord t => [(t,a)] -> EventG t a+listEG :: (Ord t, Bounded t) => [(t,a)] -> EventG t a listEG = futuresE . map (uncurry future) -- | Convert a temporally monotonic list of futures to an event-futuresE :: Ord t => [FutureG t a] -> EventG t a+futuresE :: (Ord t, Bounded t) => [FutureG t a] -> EventG t a futuresE [] = mempty futuresE (Future (t,a) : futs) = -- trace ("l2E: "++show t) $@@ -431,55 +532,55 @@ -- | Convert a temporally monotonic stream of futures to an event. Like -- 'futuresE' but it can be lazier, because there's not empty case.-futureStreamE :: Ord t => Stream (FutureG t a) -> EventG t a+futureStreamE :: (Ord t, Bounded t) => Stream (FutureG t a) -> EventG t a futureStreamE (~(Cons (Future (t,a)) futs)) = Event (Future (t, a `stepper` futureStreamE futs)) -- | Event at given times. See also 'atTimeG'.-atTimesG :: Ord t => [t] -> EventG t ()+atTimesG :: (Ord t, Bounded t) => [t] -> EventG t () atTimesG = listEG . fmap (flip (,) ()) -- | Single-occurrence event at given time.-atTimeG :: Ord t => t -> EventG t ()+atTimeG :: (Ord t, Bounded t) => t -> EventG t () atTimeG = atTimesG . pure -- | Snapshot a reactive value whenever an event occurs and apply a -- combining function to the event and reactive's values.-snapshotWith :: Ord t =>+snapshotWith :: (Ord t, Bounded t) => (a -> b -> c) -> ReactiveG t b -> EventG t a -> EventG t c -snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)- where- h (Nothing,_) = Nothing- h (Just a ,b) = Just (f a b)+-- snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)+-- where+-- h (Nothing,_) = Nothing+-- h (Just a ,b) = Just (f a b) --- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@--- didn't.-snap :: forall a b t. Ord t =>- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b)-_ `snap` Event (Future (Max MaxBound, _)) = mempty-(b0 `Stepper` eb) `snap` ea =- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)- where- fa :: a -> Unop (Maybe a, b)- fb :: b -> Unop (Maybe a, b)- fa a (_,b) = (Just a , b)- fb b _ = (Nothing, b)+-- -- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@+-- -- didn't.+-- snap :: forall a b t. (Ord t, Bounded t) =>+-- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b)+-- (b0 `Stepper` eb) `snap` ea =+-- assuming (isNeverE ea) mempty $+-- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)+-- where+-- fa :: a -> Unop (Maybe a, b)+-- fb :: b -> Unop (Maybe a, b)+-- fa a (_,b) = (Just a , b)+-- fb b _ = (Nothing, b) -- This next version from Chuan-kai Lin, so that snapshot is lazy enough -- for recursive cases. It leaks when the reactive changes faster than -- the event occurs. --- snapshotWith f r e =--- fmap snap $ accumE seed $ fmap advance $ withTimeGE e--- where snap (a, sr) = f a (rInit sr)--- seed = (undefined, r)--- advance (a, t) (_, sr) = (a, skipRT sr t)+snapshotWith f r e =+ fmap snap $ accumE seed $ fmap advance $ withTimeGE e+ where snap (a, sr) = f a (rInit sr)+ seed = (error "snapshotWith seed", r)+ advance (a, t) (_, sr) = (a, skipRT sr t) --- -- | Skip reactive values until the given time.--- skipRT :: Ord t => ReactiveG t a -> Time t -> ReactiveG t a--- r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start =--- if t < start then r1 `skipRT` start else r+-- | Skip reactive values until the given time.+skipRT :: (Ord t, Bounded t) => ReactiveG t a -> Time t -> ReactiveG t a+r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start =+ if t < start then r1 `skipRT` start else r -- From Beelsebob: @@ -505,7 +606,7 @@ a `accumR` e = a `stepper` (a `accumE` e) -- | Just the first occurrence of an event.-once :: Ord t => EventG t a -> EventG t a+once :: (Ord t, Bounded t) => EventG t a -> EventG t a once = (inEvent.fmap) (pure . rInit) -- | Extract a future representing the first occurrence of the event together@@ -521,11 +622,11 @@ -- | Truncate first event at first occurrence of second event.-untilE :: Ord t => EventG t a -> EventG t b -> EventG t a+untilE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t a ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb -- | Truncate first event at the given time.-untilET :: Ord t => EventG t a -> Time t -> EventG t a+untilET :: (Ord t, Bounded t) => EventG t a -> Time t -> EventG t a -- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t = @@ -554,7 +655,7 @@ -- 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 -- may be re-displayed.-rats :: Ord t => ReactiveG t a -> [t] -> [a] -- increasing times+rats :: (Ord t, Bounded t) => ReactiveG t a -> [t] -> [a] -- increasing times _ `rats` [] = [] @@ -563,7 +664,7 @@ | otherwise = r' `rats` ts -- Just for testing-rat :: Ord t => ReactiveG t a -> t -> a+rat :: (Ord t, Bounded t) => ReactiveG t a -> t -> a rat r = head . rats r . (:[]) @@ -572,20 +673,20 @@ --------------------------------------------------------------------} -- Standard instances-instance (Monoid_f f, Ord t) => Monoid_f (ReactiveG t :. f) where+instance (Monoid_f f, Ord t, Bounded t) => Monoid_f (ReactiveG t :. f) where { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }-instance (Ord t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip+instance (Ord t, Bounded t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip instance Unzip (ReactiveG t) where {fsts = fmap fst; snds = fmap snd} -- Standard instances-instance Ord t => Monoid_f (EventG t) where+instance (Ord t, Bounded t) => Monoid_f (EventG t) where { mempty_f = mempty ; mappend_f = mappend }-instance Ord t => Monoid ((EventG t :. f) a) where+instance (Ord t, Bounded t) => Monoid ((EventG t :. f) a) where { mempty = O mempty; mappend = inO2 mappend }-instance Ord t => Monoid_f (EventG t :. f) where+instance (Ord t, Bounded t) => Monoid_f (EventG t :. f) where { mempty_f = mempty ; mappend_f = mappend }-instance (Ord t, Cozip f) => Zip (EventG t :. f) where+instance (Ord t, Bounded t, Cozip f) => Zip (EventG t :. f) where zip = cozip -- Standard instance for functors@@ -617,7 +718,7 @@ -- TODO: Reconsider E = F :. R . Didn't work with absolute time. What -- about relative time? -instance Ord t => Pointed (ReactiveG t) where+instance (Ord t, Bounded t) => Pointed (ReactiveG t) where point = (`stepper` mempty) -- TODO: I think we can bypass mempty and so eliminate the Ord@@ -684,13 +785,24 @@ batch :: TestBatch batch = ( "Reactive.PrimReactive" , concatMap unbatch- [ ("monotonicity",+ [ + -- monad associativity fails+ -- , monad (undefined :: EventG NumT (NumT,T,NumT))+ monoid (undefined :: EventG NumT T)+ , monoid (undefined :: ReactiveG NumT [T])+ , monad (undefined :: ReactiveG NumT (NumT,T,NumT))+-- , ("occurence count",+-- [("joinE", joinEOccuranceCount)]+-- )+ , ("monotonicity", [ monotonicity2 "<*>" ((<*>) :: ApTy (EventG NumT) T T)+{- , monotonicity2 "adjustE" (adjustE :: Time NumT -> EventG NumT NumT -> EventG NumT NumT)+-} , monotonicity "join" (join :: EventG NumT (EventG NumT T) -> EventG NumT T)@@ -728,17 +840,13 @@ :: EventG NumT NumT -> EventG NumT NumT) ])- -- monad associativity fails- -- , monad (undefined :: EventG NumT (NumT,T,NumT))- , monad (undefined :: ReactiveG NumT (NumT,T,NumT))- , monoid (undefined :: EventG NumT T)- , monoid (undefined :: ReactiveG NumT [T])--- , ("occurance count",--- [("joinE", joinEOccuranceCount)]--- ) ] ) +monoid_E :: TestBatch+monoid_E = monoid (undefined :: EventG NumT T)++ -- joinEOccuranceCount :: Property -- joinEOccuranceCount = -- forAll (finiteEvent $ finiteEvent arbitrary@@ -756,25 +864,26 @@ -} monotonicity :: (Show a, Arbitrary a, Arbitrary t- ,Num t, Ord t, Ord t')+ ,Num t, Ord t, Bounded t, Ord t', Bounded t') => String -> (EventG t a -> EventG t' a') -> (String,Property) monotonicity n f = (n, property $ monotoneTest f) monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t- ,Num t, Ord t, Ord t')+ ,Num t, Ord t, Bounded t, Ord t', Bounded t') => String -> (b -> EventG t a -> EventG t' a') -> (String,Property) monotonicity2 n f = (n, property $ monotoneTest2 f) -monotoneTest :: (Ord t') => (EventG t a -> EventG t' a')- -> EventG t a- -> Bool+monotoneTest :: (Ord t', Bounded t') =>+ (EventG t a -> EventG t' a')+ -> EventG t a+ -> Bool monotoneTest f e = unsafePerformIO ( (evaluate (isMonotoneE . f $ e)) `race` slowTrue) monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t- ,Num t, Ord t, Ord t')+ ,Num t, Ord t, Bounded t, Ord t', Bounded t') => (b -> EventG t a -> EventG t' a') -> (b , EventG t a) -> Bool monotoneTest2 f (x,e) =@@ -788,43 +897,46 @@ -- TODO: Replace this stuff with a use of delay from Data.Later in checkers. -isMonotoneE :: (Ord t) => EventG t a -> Bool-isMonotoneE = liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)+isMonotoneE :: (Ord t, Bounded t) => EventG t a -> Bool+isMonotoneE = liftA2 (||) isNeverE ((uncurry isMonotoneR') . unFuture . eFuture) -isMonotoneE' :: (Ord t) => (Time t) -> EventG t a -> Bool+isMonotoneE' :: (Ord t, Bounded t) => (Time t) -> EventG t a -> Bool isMonotoneE' t =- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)+ liftA2 (||) isNeverE ((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture) -isMonotoneR :: (Ord t) => ReactiveG t a -> Bool+isMonotoneR :: (Ord t, Bounded t) => ReactiveG t a -> Bool isMonotoneR (_ `Stepper` e) = isMonotoneE e -isMonotoneR' :: (Ord t) => (Time t) -> ReactiveG t a -> Bool+isMonotoneR' :: (Ord t, Bounded t) => Time t -> ReactiveG t a -> Bool isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e -simulEventOrder :: (Arbitrary t, Num t, Ord t- ,Arbitrary t', Num t', Ord t'- ,Num t'', Ord t'', Num t''', Ord t''')+simulEventOrder :: ( Arbitrary t, Num t, Ord t, Bounded t+ , Arbitrary t', Num t', Ord t', Bounded t'+ , Num t'', Ord t'', Bounded t''+ , Num t''', Ord t''', Bounded t''') => String -> (EventG t t' -> EventG t'' t''') -> (String, Property) simulEventOrder n f = (n,forAll genEvent (isStillOrderedE . f)) where- genEvent :: (Arbitrary t1, Num t1, Ord t1, Arbitrary t2, Num t2, Ord t2)+ genEvent :: ( Arbitrary t1, Num t1, Ord t1, Bounded t1+ , Arbitrary t2, Num t2, Ord t2, Bounded t2) => Gen (EventG t1 t2) genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing increasing)- isStillOrderedE :: (Num t1, Ord t1, Num t2, Ord t2) => EventG t1 t2 -> Bool+ isStillOrderedE :: ( Num t1, Ord t1, Bounded t1+ , Num t2, Ord t2, Bounded t2) => EventG t1 t2 -> Bool isStillOrderedE =- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)+ liftA2 (||) isNeverE (isStillOrderedR . futVal . eFuture) isStillOrderedR (a `Stepper` e) = isStillOrderedE' a e isStillOrderedE' a =- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)+ liftA2 (||) isNeverE (isStillOrderedR' a . futVal . eFuture) isStillOrderedR' a (b `Stepper` e) =
src/FRP/Reactive/Reactive.hs view
@@ -18,7 +18,7 @@ module FRP.Reactive.Reactive ( module FRP.Reactive.PrimReactive- , TimeT, ITime, Future+ , ImpBounds, exactNB, {-TimeFinite,-} TimeT, ITime, Future , traceF -- * Event , Event@@ -53,6 +53,7 @@ -- vector-space import Data.VectorSpace+import Data.AffineSpace -- TypeCompose import Data.Zip (pairEdit)@@ -63,13 +64,31 @@ import FRP.Reactive.PrimReactive hiding (batch) import FRP.Reactive.Improving hiding (batch) --- | The type of finite time values.+-- -- | The type of finite time values+-- type TimeFinite = Double++-- | The type of time values with additional min & max elements. type TimeT = Double+-- type TimeT = AddBounds TimeFinite --- | Improving doubles, as used for time values in 'Event', 'Reactive',+type ImpBounds t = Improving (AddBounds t)++-- | Exact & finite content of an 'ImpBounds'+exactNB :: ImpBounds t -> t+exactNB = unNo . exact+ where+ unNo (NoBound t) = t+ unNo _ = error "exactNB: unNo on MinBound or maxBound"++-- TODO: when I switch to relative time, I won't need MinBound, so+-- introduce a HasInfinity class and use infinity in place of maxBound++-- | Improving times, as used for time values in 'Event', 'Reactive', -- and 'ReactiveB'.-type ITime = Improving TimeT+type ITime = ImpBounds TimeT +-- type ITime = Improving TimeT+ -- | Type of future values. Specializes 'FutureG'. type Future = FutureG ITime @@ -97,76 +116,81 @@ -- -- > withTimeE :: Event a -> Event (a, TimeT) withTimeE :: Ord t =>- EventG (Improving t) d -> EventG (Improving t) (d, t)-withTimeE e = second (exact.timeT) <$> withTimeGE e+ EventG (ImpBounds t) d -> EventG (ImpBounds t) (d, t)+withTimeE e = second (exactNB.timeT) <$> withTimeGE e -- | Access occurrence times in an event. Discard the rest. See also -- 'withTimeE'. -- -- > withTimeE_ :: Event a -> Event TimeT withTimeE_ :: Ord t =>- EventG (Improving t) d -> EventG (Improving t) t+ EventG (ImpBounds t) d -> EventG (ImpBounds t) t withTimeE_ = (result.fmap) snd withTimeE timeT :: Ord t => Time t -> t-timeT (Max (NoBound t)) = t-timeT _ = error "timeT: non-finite time"+timeT (Max t) = t +-- timeT (Max (NoBound t)) = t+-- timeT _ = error "timeT: non-finite time"+ -- | Single-occurrence event at given time. See 'atTimes' and 'atTimeG'. atTime :: TimeT -> Event ()-atTime = atTimeG . exactly+atTime = atTimes . pure +-- atTime = atTimeG . exactly . NoBound+ -- | Event occuring at given times. See also 'atTime' and 'atTimeG'. atTimes :: [TimeT] -> Event ()-atTimes = atTimesG . fmap exactly+atTimes = atTimesG . fmap (exactly . NoBound) + -- | Convert a temporally monotonic list of timed values to an event. See also -- the generalization 'listEG' listE :: [(TimeT,a)] -> Event a-listE = listEG . fmap (first exactly)+listE = listEG . fmap (first (exactly . NoBound)) -- | Generate a pair-valued event, given a pair of initial values and a -- 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 :: (Ord t, Bounded 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+scanlE :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> EventG t a scanlE f a e = a `accumE` (flip f <$> e) -- | Accumulate values from a monoid-typed event. Specialization of -- 'scanlE', using 'mappend' and 'mempty'.-monoidE :: (Ord t, Monoid o) => EventG t o -> EventG t o+monoidE :: (Ord t, Bounded t, Monoid o) => EventG t o -> EventG t o monoidE = scanlE mappend mempty -- | Decompose an event into its first occurrence value and a remainder -- event. See also 'firstE' and 'restE'.-firstRestE :: Ord t => EventG t a -> (a, EventG t a)+firstRestE :: (Ord t, Bounded t) => EventG t a -> (a, EventG t a) firstRestE = futVal . eventOcc -- | Extract the first occurrence value of an event. See also -- 'firstRestE' and 'restE'.-firstE :: Ord t => EventG t a -> a+firstE :: (Ord t, Bounded t) => EventG t a -> a firstE = fst . firstRestE -- | Extract the remainder an event, after its first occurrence. See also -- 'firstRestE' and 'firstE'.-restE :: Ord t => EventG t a -> EventG t a+restE :: (Ord t, Bounded t) => EventG t a -> EventG t a restE = snd . firstRestE -- | Remaining part of an event. See also 'withRestE'.-remainderR :: Ord t => EventG t a -> ReactiveG t (EventG t a)+remainderR :: (Ord t, Bounded t) => EventG t a -> ReactiveG t (EventG t a) remainderR e = e `stepper` (snd <$> withRestE e) -- | Tack remainders a second event onto values of a first event. Occurs -- when the first event occurs.-snapRemainderE :: Ord t =>+snapRemainderE :: (Ord t, Bounded t) => EventG t b -> EventG t a -> EventG t (a, EventG t b) snapRemainderE = snapshot . remainderR @@ -179,7 +203,7 @@ -- | Convert an event into a single-occurrence event, whose occurrence -- contains the remainder.-onceRestE :: Ord t => EventG t a -> EventG t (a, EventG t a)+onceRestE :: (Ord t, Bounded t) => EventG t a -> EventG t (a, EventG t a) onceRestE = once . withRestE @@ -188,39 +212,39 @@ -- the old one. Nothing will come out for the first occurrence of @e@, -- but if you have an initial value @a@, you can do @withPrevE (pure a -- `mappend` e)@.-withPrevE :: Ord t => EventG t a -> EventG t (a,a)+withPrevE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a) withPrevE e = (joinMaybes . fmap combineMaybes) $ (Nothing,Nothing) `accumE` fmap (shift.Just) e where- -- Shift newer value into (old,new) pair if present.+ -- Shift newer value into (new,old) pair if present. shift :: u -> (u,u) -> (u,u)- shift new (old,_) = (new,old)+ shift newer (new,_) = (newer,new) combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v) combineMaybes = uncurry (liftA2 (,)) -- | Same as 'withPrevE', but allow a function to combine the values. -- Provided for convenience.-withPrevEWith :: Ord t => (a -> a -> b) -> EventG t a -> EventG t b+withPrevEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b withPrevEWith f e = fmap (uncurry f) (withPrevE e) -- | 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 :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a) withNextE = (result.fmap.second) firstE withRestE -- Alt. def. -- withNextE = fmap (second firstE) . withRestE -- | Same as 'withNextE', but allow a function to combine the values. -- Provided for convenience.-withNextEWith :: Ord t => (a -> a -> b) -> EventG t a -> EventG t b+withNextEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b withNextEWith f e = fmap (uncurry f) (withNextE e) -- | Mealy-style state machine, given initial value and transition -- function. Carries along event data. See also 'mealy_'.-mealy :: Ord t => s -> (s -> s) -> EventG t b -> EventG t (b,s)+mealy :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t (b,s) mealy s0 f = scanlE h (b0,s0) where b0 = error "mealy: no initial value"@@ -228,7 +252,7 @@ -- | Mealy-style 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_ :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t s mealy_ = (result.result.result.fmap) snd mealy -- mealy_ s0 f e = snd <$> mealy s0 f e@@ -236,20 +260,21 @@ -- | 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 :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t (b,n) 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_ :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t n countE_ = (result.fmap) snd countE -- countE_ e = snd <$> countE e -- | Difference of successive event occurrences. See 'withPrevE' for a -- trick to supply an initial previous value.-diffE :: (Ord t, Num n) => EventG t n -> EventG t n-diffE = withPrevEWith (flip subtract)+diffE :: (Ord t, Bounded t, AffineSpace a) =>+ EventG t a -> EventG t (Diff a)+diffE = withPrevEWith (.-.) -- -- | Returns an event whose occurrence's value corresponds with the input -- -- event's previous occurence's value.@@ -271,11 +296,11 @@ -- | Snapshot a reactive value whenever an event occurs.-snapshot :: Ord t => ReactiveG t b -> EventG t a -> EventG t (a,b)+snapshot :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t (a,b) snapshot = snapshotWith (,) -- | Like 'snapshot' but discarding event data (often @a@ is '()').-snapshot_ :: Ord t => ReactiveG t b -> EventG t a -> EventG t b+snapshot_ :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t b snapshot_ = snapshotWith (flip const) -- Alternative implementations@@ -283,72 +308,72 @@ -- 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+whenE :: (Ord t, Bounded t) => EventG t a -> ReactiveG t Bool -> EventG t a whenE e = joinMaybes . fmap h . flip snapshot e where h (a,True) = Just a h (_,False) = Nothing -- | Like 'scanl' for reactive values. See also 'scanlE'.-scanlR :: Ord t => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a+scanlR :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a scanlR f a e = a `stepper` scanlE f a e -- | Accumulate values from a monoid-valued event. Specialization of -- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'.-monoidR :: (Ord t, Monoid a) => EventG t a -> ReactiveG t a+monoidR :: (Ord t, Bounded t, Monoid a) => EventG t a -> ReactiveG t a monoidR = scanlR mappend mempty -- Equivalently, -- monoidR = stepper mempty . monoidE -- | Combine two events into one.-eitherE :: Ord t => EventG t a -> EventG t b -> EventG t (Either a b)+eitherE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t (Either a b) eitherE ea eb = ((Left <$> ea) `mappend` (Right <$> eb)) -- | 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 @lose@.-maybeR :: Ord t => EventG t a -> EventG t b -> ReactiveG t (Maybe a)+maybeR :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t (Maybe a) maybeR get lose = Nothing `stepper` ((Just <$> get) `mappend` (Nothing <$ lose)) -- | Flip-flopping reactive value. Turns true when @ea@ occurs and false -- when @eb@ occurs.-flipFlop :: Ord t => EventG t a -> EventG t b -> ReactiveG t Bool+flipFlop :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t Bool flipFlop ea eb = False `stepper` ((True <$ ea) `mappend` (False <$ eb)) -- TODO: redefine maybeR and flipFlop in terms of eitherE. -- | Count occurrences of an event. See also 'countE'.-countR :: (Ord t, Num n) => EventG t a -> ReactiveG t n+countR :: (Ord t, Bounded t, Num n) => EventG t a -> ReactiveG t n countR e = 0 `stepper` countE_ e -- | Partition an event into segments.-splitE :: Ord t => EventG t b -> EventG t a -> EventG t (a, EventG t b)+splitE :: (Ord t, Bounded t) => EventG t b -> EventG t a -> EventG t (a, EventG t b) eb `splitE` ea = h <$> (eb `snapRemainderE` withRestE ea) where h ((a,ea'),eb') = (a, eb' `untilE` ea') -- | Switch from one event to another, as they occur. (Doesn't merge, as -- 'join' does.)-switchE :: Ord t => EventG t (EventG t a) -> EventG t a+switchE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a switchE = join . fmap (uncurry untilE) . withRestE -- | Euler integral.-integral :: forall v t. (VectorSpace v, t ~ Scalar v, Num t) =>+integral :: forall v t. (VectorSpace v, AffineSpace t, Scalar v ~ Diff t) => t -> Event t -> Reactive v -> Reactive v integral t0 newT r = sumR (snapshotWith (*^) r deltaT) where- deltaT :: Event t+ deltaT :: Event (Diff t) deltaT = diffE (pure t0 `mappend` newT) -- TODO: find out whether this integral works recursively. If not, then -- fix the implementation, rather than changing the semantics. (No -- "delayed integral".) -sumR :: Ord t => AdditiveGroup v => EventG t v -> ReactiveG t v+sumR :: (Ord t, Bounded t) => AdditiveGroup v => EventG t v -> ReactiveG t v sumR = scanlR (^+^) zeroV
src/Test/Integ.hs view
@@ -1,16 +1,52 @@ -- Simple test of recursive integrals, from Beelsebob +import Control.Arrow (first)++import Data.Max+import Data.AddBounds import FRP.Reactive.Behavior import FRP.Reactive.PrimReactive-import FRP.Reactive.Internal.Fun+import FRP.Reactive.Internal.Reactive+import FRP.Reactive.Internal.Behavior+import FRP.Reactive.Future import FRP.Reactive import FRP.Reactive.Improving -e = listE [(1,()),(2,()),(3,())]-b = integral e b :: Behavior Double-e' = listE [(0.5,0.5), (1,1), (1.5,1.5), (2,2), (2.5,2.5), (3,3)] -snaps = b `snapshot_` e'+-- For ticker+import FRP.Reactive.Internal.Clock+import FRP.Reactive.Internal.TVal+import System.IO.Unsafe --- (0.5,0.0)->(1.0,0.0)->(1.5,0.0)->(2.0,0.0)->(2.5,0.0)->(3.0,0.0)++tick = atTimes [0,0.01 .. 2]+it = integral tick++ib = 1 + it ib :: Behavior Double+e' = atTimes [0,0.1 .. 1.1]++-- [(0.0,1.0),(0.1,1.1046221254112045),(0.2,1.2081089504435316),(0.30000000000000004,1.3345038765672335),(0.4000000000000001,1.4741225085031893),(0.5000000000000001,1.6283483384592894),(0.6000000000000001,1.7987096025387035),(0.7000000000000001,1.9868944241538458),(0.8,2.1947675417764927),(0.9,2.424388786780674),(1.0,2.67803349447676),(1.1,2.7048138294215276)]++i1 = occs (ib `snapshot_` e')++itst b = occs (it b `snapshot_` e')++occs :: Event a -> [(TimeT, a)]+occs = map (first (unNo . exact . getMax) . unFuture) . eFutures+ where+ unNo (NoBound a) = a++-- [(0.0,0.0),(0.1,9.999999999999996e-2),(0.2,0.19),(0.30000000000000004,0.2900000000000001),(0.4000000000000001,0.3900000000000002),(0.5000000000000001,0.49000000000000027),(0.6000000000000001,0.5900000000000003),(0.7000000000000001,0.6900000000000004),(0.8,0.7900000000000005),(0.9,0.8900000000000006),(1.0,0.9900000000000007),(1.1,1.0000000000000007)]++i2 = itst 1++-- K 0.0 `Stepper` (1.0e-2,K 1.0e-2)->(2.0e-2,K 2.0e-2)->(3.0e-2,K 3.0e-2)->(3.9999999999999994e-2,K 3.9999999999999994e-2)->(4.999999999999999e-2,K 4.999999999999999e-2)->(5.9999999999999984e-2,K 5.9999999999999984e-2)->(6.999999999999998e-2,K 6.999999999999998e-2)->(7.999999999999997e-2,K 7.999999999999997e-2)->(8.999999999999997e-2,K 8.999999999999997e-2)->(9.999999999999996e-2,K 9.999999999999996e-2)->(0.10999999999999996,K 0.10999999999999996)->(0.11999999999999995,K 0.11999999999999995)->(0.12999999999999995,K 0.12999999999999995)->(0.13999999999999996,K 0.13999999999999996)->(0.14999999999999997,K 0.14999999999999997)->(0.15999999999999998,K 0.15999999999999998)->(0.16999999999999998,K 0.16999999999999998)->(0.18,K 0.18)->(0.19,K 0.19)->(0.2,K 0.2)-> ...++r2 = unb (it 1)++main = print i1++-- Integration seems much slower than i'd expect it to be, even in the+-- non-recursive case. Recursive and non-recursive examples slow down as+-- they go.
+ src/Test/Merge.hs view
@@ -0,0 +1,89 @@+-- Tracking down a problem with event merging++import Data.Monoid (mappend)+import Control.Applicative ((<$>))++import FRP.Reactive.Improving+import FRP.Reactive.Future+import FRP.Reactive.PrimReactive+import FRP.Reactive.Reactive+import FRP.Reactive.Internal.Future+import FRP.Reactive.Internal.Reactive+++-- (Imp 1.0,1)->(Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+e1 = listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)]++-- (Imp 1.5,100)->(Imp 2.5,200)+e2 = listEG [(exactly 1.5, 100), (exactly 2.5, 200)]++-- (Imp *** Exception: Prelude.undefined+e3 = listEG [(after 2.5, 200)]++-- (Imp 1.5,100)->(Imp 2.3,200)->(Imp *** Exception: Prelude.undefined+e3' = listEG [(exactly 1.5, 100), (exactly 2.3, 200), (after 2.5, 300)]++-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.5,200)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+e4 = e1 `mappend` e2++-- (Imp 1.0,1)->(Imp 2.0,2)<interactive>: after: comparing after+e5 = e1 `mappend` e3++-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.3,200)<interactive>: after: comparing after+e5' = e1 `mappend` e3'++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+f1 = eFuture e1++-- <NoBound Imp 1.5,100 `Stepper` (Imp 2.5,200)>+f2 = eFuture e2++-- <NoBound Imp *** Exception: Prelude.undefined+f3 = eFuture e3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+f4 = f1 `mappend` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f5 = f1 `merge` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f5' = eFuture e5++++-- ++type Binop a = a -> a -> a++mergeLR, mergeL, mergeR :: (Ord s) => Binop (FutureG s (ReactiveG s b))++-- Same as 'merge'+u `mergeLR` v = + (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)++u `mergeL` v = inFutR (`merge` v) <$> u++u `mergeR` v = inFutR (u `merge`) <$> v++-- inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b))+-- -> (ReactiveG s b -> ReactiveG t b)+++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f6 = f1 `mergeLR` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f7 :: Future (Reactive Integer)+f7 = f1 `mergeL` f3++-- <NoBound Imp *** Exception: Prelude.undefined+f8 = f1 `mergeR` f3+++f7' :: Future (Reactive Integer)++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f7' = q <$> f1+ where+ q (a `Stepper` Event u') = a `Stepper` Event (u' `merge` f3)
src/Test/Reactive.hs view
@@ -13,6 +13,8 @@ module Test.Reactive (batches,main) where +-- import Test.QuickCheck+ import Test.QuickCheck.Checkers -- import qualified Data.Unamb
+ src/Test/SimpleFilter.hs view
@@ -0,0 +1,92 @@+-- Tracking down a problem with event merging++import Data.Monoid+import Control.Applicative (pure,(<$>))+import Control.Monad (join)++import Data.Unamb++import Data.Max+import Data.AddBounds+import FRP.Reactive.Improving+import FRP.Reactive.Future+import FRP.Reactive.PrimReactive -- hiding (filterE)+import FRP.Reactive.Reactive -- hiding (filterE)+import FRP.Reactive.Internal.Future+import FRP.Reactive.Internal.Reactive++-- For neverE+import FRP.Reactive.Internal.Clock+import FRP.Reactive.Internal.TVal+import System.IO.Unsafe+++negateOdds :: Event Int -> Event Int+negateOdds e =+ (negate <$> filterE odd e) `mappend` (filterE even e)++en :: TimeT -> Improving (AddBounds TimeT)+en = exactly . NoBound++an :: TimeT -> Improving (AddBounds TimeT)+an = after . NoBound++t :: (Bounded t, Eq t) => Int -> EventG t a -> [FutureG t a]+t n = take n . eFutures++e7 :: Event Int+e7 = listEG [(en 1,1),(en 2,2),(en 3,3),(an 4,17)]+t7 = t 3 e7++e8 = filterE odd e7+t8 = t 2 e8++e9 = negate <$> e8+t9 = t 2 e9++e10 = filterE even e7+t10 = t 1 e10++e11 = e9 `mappend` e10+t11 = t 3 e11++e12 = filterE (const True) e7+t12 = t 3 e12++e13 = filterE (const True) e7 `mappend` mempty+t13 = t 3 e13++e14 = filterE (const True) e7 `mappend` listEG [(an 5, error "five")]+t14 = t 3 e14++-- One occurrence out per second +e15 = filterE (const True) e7 `mappend` neverE+t15 = t 3 e15++-- This one finishes fine.+e16 = filterE (const True) e7 `mappend` listEG [(maxBound, error "maxed out")]+t16 = t 3 e16++e17 = e7 `mappend` neverE+t17 = t 3 e17+++-- Semantically equivalent to mappend+neverE :: Event a+neverE = unsafePerformIO $+ do c <- makeClock + (_,never) <- makeEvent c+ return never++-- as expected: [<Imp NoBound C-c C-c+tN = t 1 neverE++-- Imp NoBound C-c C-c+tinf :: ITime+tinf = getMax (futTime (head tN))++-- True+p1 = en 0 <= tinf++-- GT+p2 = compareI tinf (NoBound 0)