summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorConalElliott <>2008-11-25 04:20:38 (GMT)
committerLuite Stegeman <luite@luite.com>2008-11-25 04:20:38 (GMT)
commitc36c9ba8c6378d432394dab8efcab297edb1f18a (patch)
tree5ca24f33fd3bcebe4330b29d243f285e71774885 /src
parent1d73060011d609c3aa3044482cf52be933934525 (diff)
version 0.9.30.9.3
Diffstat (limited to 'src')
-rwxr-xr-xsrc/Data/Max.hs4
-rwxr-xr-xsrc/Data/Min.hs4
-rwxr-xr-xsrc/FRP/Reactive.hs11
-rwxr-xr-xsrc/FRP/Reactive/Behavior.hs44
-rwxr-xr-xsrc/FRP/Reactive/Future.hs17
-rwxr-xr-xsrc/FRP/Reactive/Improving.hs13
-rwxr-xr-xsrc/FRP/Reactive/Internal/Future.hs5
-rwxr-xr-xsrc/FRP/Reactive/Internal/Misc.hs5
-rwxr-xr-xsrc/FRP/Reactive/Internal/Reactive.hs4
-rwxr-xr-xsrc/FRP/Reactive/Internal/TVal.hs158
-rwxr-xr-xsrc/FRP/Reactive/PrimReactive.hs121
-rwxr-xr-xsrc/FRP/Reactive/Reactive.hs39
12 files changed, 305 insertions, 120 deletions
diff --git a/src/Data/Max.hs b/src/Data/Max.hs
index 2947305..aa524a9 100755
--- a/src/Data/Max.hs
+++ b/src/Data/Max.hs
@@ -17,8 +17,8 @@ module Data.Max (Max(..)) where
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
index 20d7094..8cb4eeb 100755
--- a/src/Data/Min.hs
+++ b/src/Data/Min.hs
@@ -16,8 +16,8 @@ module Data.Min (Min(..)) where
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
index 1a1f998..e7e5f03 100755
--- a/src/FRP/Reactive.hs
+++ b/src/FRP/Reactive.hs
@@ -18,22 +18,23 @@ module FRP.Reactive
, 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 @@ module FRP.Reactive
-- 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
index 60979c3..7ce3175 100755
--- 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 @@ module FRP.Reactive.Behavior
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 @@ rToB = beh . fmap pure
-- | 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 @@ snapshot = snapshotWith (,)
-- 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 @@ snapshot_ = snapshotWith (flip const)
-- 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 @@ monoidB = scanlB mappend mempty
-- | 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 @@ integral t = sumB . snapshotWith (*^) (diffE (t `snapshot_` time))
--
-- 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
index bcf38b0..1bd6a5e 100755
--- a/src/FRP/Reactive/Future.hs
+++ b/src/FRP/Reactive/Future.hs
@@ -101,13 +101,6 @@ instance Ord t => Monoid (FutureG t a) where
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,_)) =
@@ -125,6 +118,16 @@ instance Ord t => Monoid (FutureG t a) where
-- '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.
+
{----------------------------------------------------------
Tests
diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs
index 1997d33..2f4e3a7 100755
--- a/src/FRP/Reactive/Improving.hs
+++ b/src/FRP/Reactive/Improving.hs
@@ -17,9 +17,9 @@ module FRP.Reactive.Improving
) 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 :: Ord a => a -> Improving a
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 @@ instance Ord a => Ord (Improving a) where
-- | 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 @@ Imp u uComp `minI` Imp v vComp = (Imp uMinV wComp, uLeqV)
-- | 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@.
@@ -75,5 +76,7 @@ Imp u uComp `maxI` Imp v vComp = (Imp uMaxV wComp, uGeqV)
-- 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
index e64ecb9..b2071cd 100755
--- a/src/FRP/Reactive/Internal/Future.hs
+++ b/src/FRP/Reactive/Internal/Future.hs
@@ -46,11 +46,6 @@ newtype FutureG t a = Future { unFuture :: (Time t, a) }
-- 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
index 6e650fa..9a72a23 100755
--- 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
index 43a74ac..143af38 100755
--- a/src/FRP/Reactive/Internal/Reactive.hs
+++ b/src/FRP/Reactive/Internal/Reactive.hs
@@ -132,7 +132,7 @@ inEvent2 f = inEvent . f . eFuture
-- 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 @@ instance (Show x, Show y) => Show (ReactiveG x y) where
-- | 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
index 524da93..4f42e71 100755
--- 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,33 +39,39 @@ import FRP.Reactive.Internal.Timing (sleepPast)
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))
- )
-
--- 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.
+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)
+
+ 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
@@ -72,8 +79,8 @@ 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 @@ type Fed a b = (a, Sink b)
-- | 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 @@ makeFuture = (fmap.fmap.first) tValFuture makeTVal
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
index b8d0793..2088a7c 100755
--- a/src/FRP/Reactive/PrimReactive.hs
+++ b/src/FRP/Reactive/PrimReactive.hs
@@ -46,11 +46,12 @@ module FRP.Reactive.PrimReactive
, 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 Prelude hiding (zip)
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 @@ instance (Ord t, Monoid a) => Monoid (ReactiveG t a) where
-- | 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 @@ u `merge` v =
-- 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 @@ instance Ord t => Monad (EventG t) where
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 @@ happy a@(Event (Future (t0, e `Stepper` ee'))) t b
| 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,16 +241,24 @@ joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _)))))))
-- 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:
@@ -266,6 +283,26 @@ adjustE t0h (Event (Future (tah, ~(a `Stepper` e)))) =
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 @@ instance Ord t => Monad (ReactiveG t) where
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 @@ ea `snap` (b0 `Stepper` eb) =
-- | 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 @@ 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 = 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 @@ eventOcc (Event fut) = (\ (Stepper a e) -> (a,e)) <$> fut
-- | 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 @@ 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
+
-- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t =
-- if ta < t then
-- Event (Future (ta, a `Stepper` (e' `untilET` t)))
@@ -422,6 +509,8 @@ Event (Future ~(ta, a `Stepper` e')) `untilET` t =
-- 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 @@ filterMP p m = joinMaybes (liftM f m)
-- 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 @@ batch = ( "Reactive.PrimReactive"
[ ("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
index 40726b5..ff11e22 100755
--- a/src/FRP/Reactive/Reactive.hs
+++ b/src/FRP/Reactive/Reactive.hs
@@ -24,11 +24,11 @@ module FRP.Reactive.Reactive
, 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 @@ withTimeE e = second (exact.timeT) <$> withTimeGE e
-- | 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 :: [(TimeT,a)] -> Event a
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 @@ 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 = (fmap.fmap.fmap) firstE withRestE
+withNextE = (result.fmap.second) firstE withRestE
-- Alt. def.
-- withNextE = fmap (second firstE) . withRestE
@@ -208,30 +209,30 @@ withNextEWith f e = fmap (uncurry f) (withNextE e)
-- | 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 @@ snapshot_ = snapshotWith (flip const)
-- 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