summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorConalElliott <>2008-10-29 00:22:48 (GMT)
committerLuite Stegeman <luite@luite.com>2008-10-29 00:22:48 (GMT)
commit87bed19709e3c4c38e74ffffd7e81e2f2f0ebf67 (patch)
treebd14f0328842257a1c2d87f1f0f29f53871cc903 /src
parent051cf8541921e2a2ec7badae76d8f126783ffa86 (diff)
version 0.8.30.8.3
Diffstat (limited to 'src')
-rwxr-xr-xsrc/Data/AddBounds.hs76
-rwxr-xr-xsrc/Data/EventExtras.hs107
-rwxr-xr-xsrc/Data/Fun.hs58
-rwxr-xr-xsrc/Data/Future.hs171
-rwxr-xr-xsrc/Data/Improving.hs53
-rwxr-xr-xsrc/Data/MEvent.hs72
-rwxr-xr-xsrc/Data/Max.hs30
-rwxr-xr-xsrc/Data/Min.hs28
-rwxr-xr-xsrc/Data/PairMonad.hs40
-rwxr-xr-xsrc/Data/Reactive.hs498
-rwxr-xr-xsrc/Data/SEvent.hs168
-rwxr-xr-xsrc/Data/SFuture.hs195
-rwxr-xr-xsrc/Data/SImproving.hs60
-rwxr-xr-xsrc/Data/SReactive.hs169
-rwxr-xr-xsrc/Data/Unamb.hs83
-rwxr-xr-xsrc/Examples.hs2
-rwxr-xr-xsrc/FRP/Reactive.hs46
-rwxr-xr-xsrc/FRP/Reactive/Behavior.hs138
-rwxr-xr-xsrc/FRP/Reactive/Fun.hs139
-rwxr-xr-xsrc/FRP/Reactive/Future.hs196
-rwxr-xr-xsrc/FRP/Reactive/Improving.hs79
-rwxr-xr-xsrc/FRP/Reactive/Internal/Behavior.hs64
-rwxr-xr-xsrc/FRP/Reactive/Internal/Clock.hs59
-rwxr-xr-xsrc/FRP/Reactive/Internal/Fun.hs18
-rwxr-xr-xsrc/FRP/Reactive/Internal/Future.hs77
-rwxr-xr-xsrc/FRP/Reactive/Internal/IVar.hs44
-rwxr-xr-xsrc/FRP/Reactive/Internal/Misc.hs23
-rwxr-xr-xsrc/FRP/Reactive/Internal/Reactive.hs217
-rwxr-xr-xsrc/FRP/Reactive/Internal/Serial.hs35
-rwxr-xr-xsrc/FRP/Reactive/Internal/TVal.hs108
-rwxr-xr-xsrc/FRP/Reactive/Internal/Timing.hs92
-rwxr-xr-xsrc/FRP/Reactive/LegacyAdapters.hs87
-rwxr-xr-xsrc/FRP/Reactive/Num.hs56
-rwxr-xr-xsrc/FRP/Reactive/PrimReactive.hs759
-rwxr-xr-xsrc/FRP/Reactive/Reactive.hs292
-rwxr-xr-xsrc/FRP/Reactive/SImproving.hs173
-rwxr-xr-xsrc/FRP/Reactive/Sorted.hs77
-rwxr-xr-xsrc/FRP/Reactive/VectorSpace.hs19
-rwxr-xr-xsrc/Test/Reactive.hs33
39 files changed, 3006 insertions, 1635 deletions
diff --git a/src/Data/AddBounds.hs b/src/Data/AddBounds.hs
new file mode 100755
index 0000000..a02311a
--- /dev/null
+++ b/src/Data/AddBounds.hs
@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.AddBounds
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Add bounds to an ordered type
+----------------------------------------------------------------------
+
+module Data.AddBounds (AddBounds(..)) where
+
+import Control.Applicative (pure,(<$>))
+
+-- Testing
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+
+
+-- | Wrap a type into one having new least and greatest elements,
+-- preserving the existing ordering.
+data AddBounds a = MinBound | NoBound a | MaxBound
+ deriving (Eq {-, Ord-}, Read, Show)
+
+instance Bounded (AddBounds a) where
+ minBound = MinBound
+ maxBound = MaxBound
+
+
+-- Normally, I'd derive 'Ord' as well, but there's a sticky point. The
+-- derived instance uses the default definition of 'min', which is uses
+-- '(<=)' and thus cannot exploit any partial information. So, define our
+-- own 'min' in terms of 'min' on @a@.
+-- Examples:
+-- (NoBound undefined) `min` (NoBound undefined) can return (NoBound _|_)
+-- using this definition, but will not produce any output using the
+-- default min.
+--
+-- (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
+
+ 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
+
+
+instance Arbitrary a => Arbitrary (AddBounds a) where
+ arbitrary = frequency [ (1 ,pure MinBound)
+ , (10, NoBound <$> arbitrary)
+ , (1 ,pure MaxBound) ]
+ coarbitrary MinBound = variant 0
+ coarbitrary (NoBound a) = variant 1 . coarbitrary a
+ coarbitrary MaxBound = variant 2
+
+instance (EqProp a, Eq a) => EqProp (AddBounds a) where
+ NoBound a =-= NoBound b = a =-= b
+ u =-= v = u `eq` v
diff --git a/src/Data/EventExtras.hs b/src/Data/EventExtras.hs
deleted file mode 100755
index c21306a..0000000
--- a/src/Data/EventExtras.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-{-# OPTIONS_GHC -Wall #-}
-----------------------------------------------------------------------
--- |
--- Module : Data.EventExtras
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Event "extras", i.e., independent of representation
-----------------------------------------------------------------------
-
-module Data.EventExtras
- (
- module Data.SEvent
- -- * Event extras
- , EventD, EventI
- , traceE, pairE, scanlE, monoidE
- , withPrevE, countE, countE_, diffE
- -- * To be moved elsewhere
- , joinMaybes, filterMP
- ) where
-
-import Control.Monad (liftM)
-import Control.Applicative ((<$>),liftA2)
-import Data.Pair (pairEdit)
-import Data.Monoid
-import Control.Monad (MonadPlus(..))
-import Debug.Trace (trace)
-
-import Data.SEvent
--- import Data.MEvent
-
-import Data.Improving
-
--- | Event, using Double for time
-type EventD = Event' Double
-
--- | Event, using an /improving/ double for time
-type EventI = Event' (Improving Double)
-
--- | Tracing of events.
-traceE :: (a -> String) -> Event' t a -> Event' t a
-traceE shw = fmap (\ a -> trace (shw a) a)
-
-pairE :: Ord t => (c,d) -> (Event' t c, Event' t d) -> Event' t (c,d)
-pairE cd cde = cd `accumE` pairEdit cde
-
--- | Like 'scanl' for events. See also 'scanlR'.
-scanlE :: Ord t => (a -> b -> a) -> a -> Event' t b -> Event' t a
-scanlE f a e = a `accumE` (flip f <$> e)
-
--- | Accumulate values from a monoid-valued event. Specialization of
--- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidR'.
-monoidE :: (Ord t, Monoid o) => Event' t o -> Event' t o
-monoidE = scanlE mappend mempty
-
--- | Pair each event value with the previous one, given an initial value.
-withPrevE :: Ord t => Event' t a -> Event' 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 :: u -> (u,u) -> (u,u)
- shift new (_,old) = (old,new)
- combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
- combineMaybes = uncurry (liftA2 (,))
-
--- | Count occurrences of an event, remembering the occurrence values.
--- See also 'countE_'.
-countE :: (Ord t, Num n) => Event' t b -> Event' t (b,n)
-countE = scanlE h (b0,0)
- where
- b0 = error "withCountE: no initial value"
- h (_,n) b = (b,n+1)
-
--- | Count occurrences of an event, forgetting the occurrence values. See
--- also 'countE'. See also 'countR'.
-countE_ :: (Ord t, Num n) => Event' t b -> Event' t n
-countE_ e = snd <$> countE e
-
--- | Difference of successive event occurrences.
-diffE :: (Ord t, Num n) => Event' t n -> Event' t n
-diffE e = uncurry (-) <$> withPrevE e
-
-
-{--------------------------------------------------------------------
- To be moved elsewhere
---------------------------------------------------------------------}
-
--- | Pass through @Just@ occurrences.
-joinMaybes :: MonadPlus m => m (Maybe a) -> m a
-joinMaybes = (>>= maybe mzero return)
-
--- | Pass through values satisfying @p@.
-filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
-filterMP p m = joinMaybes (liftM f m)
- where
- f a | p a = Just a
- | otherwise = Nothing
-
--- Alternatively:
--- filterMP p m = m >>= guarded p
--- where
--- guarded p x = guard (p x) >> return x
-
diff --git a/src/Data/Fun.hs b/src/Data/Fun.hs
deleted file mode 100755
index 53a0fbf..0000000
--- a/src/Data/Fun.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Data.Fun
--- Copyright : (c) Conal Elliott 2007
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Functions, with constant functions optimized. With instances of
--- 'Functor', 'Applicative', 'Monad', and 'Arrow'
-----------------------------------------------------------------------
-
-module Data.Fun (Fun(..), apply) where
-
-import Data.Monoid (Monoid(..))
-import Control.Applicative (Applicative(..))
-import Control.Arrow hiding (pure)
-
--- | Constant-optimized functions
-data Fun t a = K a -- ^ constant function
- | Fun (t -> a) -- ^ non-constant function
-
--- | 'Fun' as a function
-apply :: Fun t a -> (t -> a)
-apply (K a) = const a
-apply (Fun f) = f
-
-instance Monoid a => Monoid (Fun t a) where
- mempty = K mempty
- K a `mappend` K a' = K (a `mappend` a')
- funa `mappend` funb = Fun (apply funa `mappend` apply funb)
-
-instance Functor (Fun t) where
- fmap f (K a) = K (f a)
- fmap f (Fun g) = Fun (f.g)
- -- Or use
- -- fmap f = (pure f <*>)
-
-instance Applicative (Fun t) where
- pure = K
- K f <*> K x = K (f x)
- cf <*> cx = Fun (apply cf <*> apply cx)
-
-instance Monad (Fun t) where
- return = pure
- K a >>= h = h a
- Fun f >>= h = Fun (f >>= apply . h)
-
-instance Arrow Fun where
- arr = Fun
- _ >>> K b = K b
- K a >>> Fun g = K (g a)
- Fun g >>> Fun f = Fun (g >>> f)
- first = Fun . first . apply
- second = Fun . second . apply
- K a' *** K b' = K (a',b')
- f *** g = first f >>> second g
diff --git a/src/Data/Future.hs b/src/Data/Future.hs
deleted file mode 100755
index 561c23e..0000000
--- a/src/Data/Future.hs
+++ /dev/null
@@ -1,171 +0,0 @@
--- {-# LANGUAGE RecursiveDo #-}
--- For ghc-6.6 compatibility
-{-# OPTIONS_GHC -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module : Data.Future
--- Copyright : (c) Conal Elliott 2007
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- A /future value/ is a value that will become knowable only later. This
--- module gives a way to manipulate them functionally. For instance,
--- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable.
--- See <http://en.wikipedia.org/wiki/Futures_and_promises>.
---
--- Primitive futures can be things like /the value of the next key you
--- press/, or /the value of LambdaPix stock at noon next Monday/.
---
--- Composition is via standard type classes: 'Functor', 'Applicative',
--- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of
--- these classes:
---
--- * Monoid: 'mempty' is a future that never becomes knowable.
--- @a `mappend` b@ is whichever of @a@ and @b@ is knowable first.
---
--- * 'Functor': apply a function to a future. The result is knowable when
--- the given future is knowable.
---
--- * 'Applicative': 'pure' gives value knowable since the beginning of
--- time. '(\<*\>)' applies a future function to a future argument.
--- Result available when /both/ are available, i.e., it becomes knowable
--- when the later of the two futures becomes knowable.
---
--- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@ cascades
--- futures. 'join' resolves a future future into a future.
---
--- The current implementation is nondeterministic in 'mappend' for futures
--- that become knowable at the same time or nearly the same time. I
--- want to make a deterministic implementation.
---
--- See "Data.SFuture" for a simple denotational semantics of futures. The
--- current implementation /does not/ quite implement this target semantics
--- for 'mappend' when futures are available simultaneously or nearly
--- simultaneously. I'm still noodling how to implement that semantics.
-----------------------------------------------------------------------
-
-module Data.Future
- ( Future(..), force, newFuture
- , future
- , runFuture
- ) where
-
-import Control.Concurrent
-import Data.Monoid (Monoid(..))
-import Control.Applicative
-import Control.Monad (join,forever)
-import System.IO.Unsafe
--- import Foreign (unsafePerformIO)
-
--- TypeCompose
-import Control.Instances () -- IO monoid
-
--- About determinacy: for @f1 `mappend` f2@, we might get @f2@ instead of
--- @f1@ even if they're available simultaneously. It's even possible to
--- get the later of the two if they're nearly simultaneous.
---
--- What will it take to get deterministic semantics for @f1 `mappend` f2@?
--- Idea: make an "event occurrence" type, which is a future with a time
--- and a value. (The time is useful for snapshotting continuous
--- behaviors.) When one occurrence happens with a time @t@, query whether
--- the other one occurs by the same time. What does it take to support
--- this query operation?
---
--- Another idea: speculative execution. When one event occurs, continue
--- to compute consequences. If it turns out that an earlier occurrence
--- arrives later, do some kind of 'retry'.
-
--- The implementation is very like IVars. Each future contains an MVar
--- reader. 'force' blocks until the MVar is written.
-
--- | Value available in the future.
-data Future a =
- -- | Future that may arrive. The 'IO' blocks until available. No side-effect.
- Future (IO a)
- -- | Future that never arrives.
- | Never
-
--- Why not simply use @a@ (plain-old lazy value) in place of @IO a@ in
--- 'Future'? Several of the definitions below get simpler, and many
--- examples work. See NewFuture.hs. But sometimes that implementation
--- mysteriously crashes or just doesn't update. Odd.
-
--- | Access a future value. Blocks until available.
-force :: Future a -> IO a
-force (Future io) = io
-force Never = hang
-
--- | Block forever
-hang :: IO a
-hang = do -- putStrLn "warning: blocking forever."
- -- Any never-terminating computation goes here
- -- This one can yield an exception "thread blocked indefinitely"
- -- newEmptyMVar >>= takeMVar
- -- sjanssen suggests this alternative:
- forever $ threadDelay maxBound
- -- forever's return type is (), though it could be fully
- -- polymorphic. Until it's fixed, I need the following line.
- return undefined
-
--- | Make a 'Future' and a way to fill it. The filler should be invoked
--- only once.
-newFuture :: IO (Future a, a -> IO ())
-newFuture = do v <- newEmptyMVar
- return (Future (readMVar v), putMVar v)
-
--- | Make a 'Future', given a way to compute a value.
-future :: IO a -> Future a
-future mka = unsafePerformIO $
- do (fut,sink) <- newFuture
- forkIO $ mka >>= sink
- return fut
-{-# NOINLINE future #-}
-
-instance Functor Future where
- fmap f (Future get) = future (fmap f get)
- fmap _ Never = Never
-
-instance Applicative Future where
- pure a = Future (pure a)
- Future getf <*> Future getx = future (getf <*> getx)
- _ <*> _ = Never
-
--- Note Applicative's pure uses 'Future' as an optimization over
--- 'future'. No thread or MVar.
-
-instance Monad Future where
- return = pure
- Future geta >>= h = future (geta >>= force . h)
- Never >>= _ = Never
-
-instance Monoid (Future a) where
- mempty = Never
- mappend = race
-
--- | Race to extract a value.
-race :: Future a -> Future a -> Future a
-Never `race` b = b
-a `race` Never = a
-a `race` b = unsafePerformIO $
- do (c,sink) <- newFuture
- lock <- newEmptyMVar -- to avoid double-kill
- let run fut tid = forkIO $ do x <- force fut
- putMVar lock ()
- killThread tid
- sink x
- mdo ta <- run a tb
- tb <- run b ta
- return ()
- return c
-{-# NOINLINE race #-}
-
--- TODO: make race deterministic, using explicit times. Figure out how
--- one thread can inquire whether the other whether it is available by a
--- given time, and if so, what time.
-
--- | Run an 'IO'-action-valued 'Future'.
-runFuture :: Future (IO ()) -> IO ()
-runFuture = join . force
diff --git a/src/Data/Improving.hs b/src/Data/Improving.hs
deleted file mode 100755
index 1d7eca6..0000000
--- a/src/Data/Improving.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Data.Improving
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Improving values -- efficient version
-----------------------------------------------------------------------
-
-module Data.Improving
- (
- Improving(..), minI
- ) where
-
-
-import Data.Unamb (unamb,assuming)
-
-{----------------------------------------------------------
- Improving values
-----------------------------------------------------------}
-
--- | An improving value.
-data Improving a = IV a (a -> Ordering)
-
--- | A known improving value (which doesn't really improve)
-exactly :: Ord a => a -> Improving a
-exactly a = IV a (compare a)
-
-instance Eq a => Eq (Improving a) where
- IV a _ == IV b _ = a == b
-
-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)
-IV u uComp `minI` IV v vComp = (IV uMinV wComp, uLeqV)
- where
- 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.
- minComp = if uLeqV then uComp else vComp
- wComp t = minComp t `unamb`
- assuming (uCompT == vCompT) uCompT
- where
- uCompT = uComp t
- vCompT = vComp t
diff --git a/src/Data/MEvent.hs b/src/Data/MEvent.hs
deleted file mode 100755
index 2106ef1..0000000
--- a/src/Data/MEvent.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeOperators, TypeSynonymInstances, MultiParamTypeClasses #-}
-
-----------------------------------------------------------------------
--- |
--- Module : Data.MEvent
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Event implementation via semantics & Maybe
-----------------------------------------------------------------------
-
-module Data.MEvent
- (
- -- * Event primitives
- Event', accumE
- ) where
-
-import Data.Monoid
-import Data.Maybe
-import Control.Monad (MonadPlus(..))
-
--- TypeCompose
-import Control.Compose ((:.)(..),inO,inO2)
-
-import qualified Data.SEvent as SR -- semantics
-
-
-{----------------------------------------------------------
- Event primitives
-----------------------------------------------------------}
-
--- | General events. 'Functor', 'Applicative', and 'Monoid' by
--- construction. See also 'Event\''.
--- In this representation, an event is a list of time/maybe pairs. The
--- 'Just's correspond to occurrences and the 'Nothing's to
--- non-occurrences.
-type Event' t = SR.Event' t :. Maybe
-
--- The 'Monad' instance is thanks to Data.SEvent:
---
--- instance Ord t => DistribM (Event' t) Maybe where ...
-
--- TODO: revisit Phooey. Can I use :. in place of monad transformers?
--- How to monad transformers relate to the monad instance of (:.)?
--- Follow up on references from my chat with Cale on 2008-03-02.
-
--- One of the standard Monoid instances for type compositions. This one
--- interleaves occurrences.
-instance Ord t => Monoid (Event' t a) where
- mempty = O mempty
- mappend = inO2 mappend -- interleave
-
--- This MonadPlus instance could go in EventExtras, but it would be an
--- orphan there.
-instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }
-
-
--- | Accumulating event, starting from an initial value and a
--- update-function event.
-accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a
-accumE a = inO $ fmap Just . SR.accumE a . fmap (fromMaybe id)
-
--- TODO: redefine accumE to preserve 'Nothing's, for later optimization.
-
--- (<*>) :: Fut (a->a) -> Fut a -> Fut a
-
--- (<*>) (on futures) does some unnecessary work here, since the function
--- is guaranteed to be at least as new as the argument.
diff --git a/src/Data/Max.hs b/src/Data/Max.hs
new file mode 100755
index 0000000..2947305
--- /dev/null
+++ b/src/Data/Max.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Max
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Max monoid
+----------------------------------------------------------------------
+
+module Data.Max (Max(..)) where
+
+
+import Data.Monoid (Monoid(..))
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+
+
+-- | Ordered monoid under 'max'.
+newtype Max a = Max { getMax :: a }
+ deriving (Eq, Ord, Bounded, Read, Show, EqProp, Arbitrary)
+
+instance (Ord a, Bounded a) => Monoid (Max a) where
+ mempty = Max minBound
+ Max a `mappend` Max b = Max (a `max` b)
diff --git a/src/Data/Min.hs b/src/Data/Min.hs
new file mode 100755
index 0000000..20d7094
--- /dev/null
+++ b/src/Data/Min.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Min
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Min monoid
+----------------------------------------------------------------------
+
+module Data.Min (Min(..)) where
+
+import Data.Monoid (Monoid(..))
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+
+-- | Ordered monoid under 'min'.
+newtype Min a = Min { getMin :: a }
+ deriving (Eq, Ord, Read, Show, Bounded, EqProp, Arbitrary)
+
+instance (Ord a, Bounded a) => Monoid (Min a) where
+ mempty = Min maxBound
+ Min a `mappend` Min b = Min (a `min` b)
diff --git a/src/Data/PairMonad.hs b/src/Data/PairMonad.hs
new file mode 100755
index 0000000..2170322
--- /dev/null
+++ b/src/Data/PairMonad.hs
@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.PairMonad
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Writer monad as a pair. Until it's in Control.Monad.Instances.
+--
+-- Use @import Data.PairMonad ()@
+----------------------------------------------------------------------
+
+module Data.PairMonad () where
+
+import Data.Monoid
+import Control.Applicative
+
+
+-- Orphan instance:
+
+-- Equivalent to the Monad Writer instance.
+instance Monoid o => Monad ((,) o) where
+ return = pure
+ (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a
+
+-- Alternatively,
+-- m >>= f = join (fmap f m)
+-- where
+-- join ((o, (o',a))) = (o `mappend` o', a)
+-- Or even,
+-- (o,a) >>= f = (o,id) <*> f a
+--
+-- I prefer the join version, because it's the standard (>>=)-via-join,
+-- plus a very simple definition for join. Too bad join isn't a method of
+-- Monad, with (>>=) and join defined in terms of each other. Why isn't
+-- it? Probably because Monad isn't derived from Functor. Was that an
+-- oversight?
diff --git a/src/Data/Reactive.hs b/src/Data/Reactive.hs
deleted file mode 100755
index 216d6cf..0000000
--- a/src/Data/Reactive.hs
+++ /dev/null
@@ -1,498 +0,0 @@
--- {-# LANGUAGE TypeOperators, ScopedTypeVariables, PatternSignatures
--- , FlexibleInstances
--- #-}
-
--- For ghc-6.6 compatibility
-{-# OPTIONS_GHC -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module : Data.Reactive
--- Copyright : (c) Conal Elliott 2007
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Functional /events/ and /reactive values/. An 'Event' is stream of
--- future values in time order. A 'Reactive' value is a discretly
--- time-varying value. These two types are closely linked: a reactive
--- value is defined by an initial value and an event that yields future
--- values; while an event is simply a future reactive value.
---
--- Many of the operations on events and reactive values are packaged as
--- instances of the standard type classes 'Monoid', 'Functor',
--- 'Applicative', and 'Monad'.
---
--- Although the basic 'Reactive' type describes /discretely/-changing
--- values, /continuously/-changing values are modeled simply as reactive
--- functions. For convenience, this module defines 'ReactiveB' as a type
--- composition of 'Reactive' and a constant-optimized representation of
--- functions of time.
---
--- The exact packaging of discrete vs continuous will probably change with
--- more experience.
-----------------------------------------------------------------------
-
-module Data.Reactive
- ( -- * Events and reactive values
- Event(..), Reactive(..), Source, inEvent, inEvent2
- , stepper, switcher, mkEvent, mkEventTrace, mkEventShow
- , runE, forkE, subscribe, forkR
- -- * Event extras
- , accumE, scanlE, monoidE
- , withPrevE, countE, countE_, diffE
- , snapshot, snapshot_, whenE, once, traceE, eventX
- -- * Reactive extras
- , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR
- -- * Reactive behaviors
- , Time, ReactiveB
- -- * To be moved elsewhere
- , replace, forget
- , Action, Sink
- , joinMaybes, filterMP
- ) where
-
-import Data.Monoid
-import Control.Arrow (first,second)
-import Control.Applicative
-import Control.Monad
-import Debug.Trace (trace)
-import Data.IORef
-import Control.Concurrent -- (forkIO,ThreadId)
-
-import Data.Maybe
-
--- TypeCompose
-import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..))
-import Data.Pair
-
-import Data.Future
-import Data.Fun
-
-
-{--------------------------------------------------------------------
- Events and reactive values
---------------------------------------------------------------------}
-
--- | Event, i.e., a stream of future values. Instances:
---
--- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend`
--- e'@ is the event that combines occurrences from @e@ and @e'@. (Fran's
--- @neverE@ and @(.|.)@.)
---
--- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs,
--- and whose occurrence values come from applying @f@ to the values from
--- @e@. (Fran's @(==>)@.)
---
--- * 'Applicative': @pure a@ is an event with a single occurrence,
--- available from the beginning of time. @ef \<*\> ex@ is an event whose
--- occurrences are made from the /product/ of the occurrences of @ef@ and
--- @ex@. For every occurrence @f@ at time @tf@ of @ef@ and occurrence @x@
--- at time @tx@ of @ex@, @ef \<*\> ex@ has an occurrence @f x@ at time @max
--- tf tx@.
---
--- * 'Monad': @return a@ is the same as @pure a@ (as always). In @e >>=
--- f@, each occurrence of @e@ leads, through @f@, to a new event.
--- Similarly for @join ee@, which is somehow simpler for me to think
--- about. The occurrences of @e >>= f@ (or @join ee@) correspond to the
--- union of the occurrences of all such events. For example, suppose
--- we're playing Asteroids and tracking collisions. Each collision can
--- break an asteroid into more of them, each of which has to be tracked
--- for more collisions. Another example: A chat room has an /enter/
--- event, whose occurrences contain new events like /speak/. An
--- especially useful monad-based function is 'joinMaybes', which filters a
--- Maybe-valued event.
---
-newtype Event a = Event { eFuture :: Future (Reactive a) }
-
--- | Reactive value: a discretely changing value. Reactive values can be
--- understood in terms of (a) a simple denotational semantics of reactive
--- values as functions of time, and (b) the corresponding instances for
--- functions. The semantics is given by the function @(%$) :: Reactive a
--- -> (Time -> a)@. A reactive value also has a current value and an
--- event (stream of future values).
---
--- Instances for 'Reactive'
---
--- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then
--- @Reactive o@ is a monoid, with @mempty = pure mempty@, and @mappend =
--- liftA2 mappend@. In other words, @mempty %$ t == mempty@, and @(r
--- `mappend` s) %$ t == (r %$ t) `mappend` (s %$ t).@
---
--- * 'Functor': @fmap f r %$ t == f (r %$ t)@.
---
--- * 'Applicative': @pure a %$ t == a@, and @(s \<*\> r) %$ t ==
--- (s %$ t) (r %$ t)@.
---
--- * 'Monad': @return a %$ t == a@, and @join rr %$ t == (rr %$ t)
--- %$ t@. As always, @(r >>= f) == join (fmap f r)@.
---
-data Reactive a =
- Stepper {
- rInit :: a -- ^ initial value
- , rEvent :: Event a -- ^ waiting for event
- }
-
--- data Reactive a = a `Stepper` Event a
-
--- | Reactive value from an initial value and a new-value event.
-stepper :: a -> Event a -> Reactive a
-stepper = Stepper
-
--- | Compatibility synonym (for ease of transition from DataDriven)
-type Source = Reactive
-
--- | Apply a unary function inside an 'Event' representation.
-inEvent :: (Future (Reactive a) -> Future (Reactive b)) -> (Event a -> Event b)
-inEvent f = Event . f . eFuture
-
--- | Apply a unary function inside an 'Event' representation.
-inEvent2 :: (Future (Reactive a) -> Future (Reactive b) -> Future (Reactive c))
- -> (Event a -> Event b -> Event c)
-inEvent2 f = inEvent . f . eFuture
-
--- Why the newtype for Event? Because the 'Monoid' instance of 'Future'
--- does not do what I want for 'Event'. It will pick just the
--- earlier-occurring event, while I want an interleaving of occurrences
--- from each.
-
-instance Monoid (Event a) where
- mempty = Event mempty
- mappend = inEvent2 merge
-
--- Standard instance for Applicative of Monoid
-instance Monoid a => Monoid (Reactive a) where
- mempty = pure mempty
- mappend = liftA2 mappend
-
--- | Merge two 'Future' streams into one.
-merge :: Future (Reactive a) -> Future (Reactive a) -> Future (Reactive a)
-Never `merge` fut = fut
-fut `merge` Never = fut
-u `merge` v =
- (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v)
- where
- onFut f (a `Stepper` Event t') = a `stepper` Event (f t')
-
-instance Functor Event where
- fmap f = inEvent $ (fmap.fmap) f
-
--- I could probably define an Applicative instance like []'s for Event,
--- i.e., apply all functions to all arguments. I don't think I want that
--- semantics.
-
-instance Functor Reactive where
- fmap f (a `Stepper` e) = f a `stepper` fmap f e
-
-instance Applicative Event where { pure = return; (<*>) = ap }
-
-instance Applicative Reactive where
- pure a = a `stepper` mempty
- rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) =
- f x `stepper` Event fut
- where
- fut = fmap (\ rf' -> rf' <*> rx ) futf `mappend`
- fmap (\ rx' -> rf <*> rx') futx
-
--- More succinctly,
---
--- rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) =
--- f x `stepper` Event (((<*> rx) <$> futf) `mappend` ((rf <*>) <$> futx))
-
-
--- A wonderful thing about the <*> definition for Reactive is that it
--- automatically caches the previous value of the function or argument
--- when the argument or function changes.
-
--- TODO: The definitions of merge and <*> have some similarities. Can I
--- factor out a common pattern?
-
-instance Monad Event where
- return a = Event (pure (pure a))
- e >>= f = joinE (fmap f e)
-
-joinE :: forall a. Event (Event a) -> Event a
-joinE = inEvent q
- where
- q :: Future (Reactive (Event a)) -> Future (Reactive a)
- q = (>>= eFuture . h)
- h :: Reactive (Event a) -> Event a
- h (ea `Stepper` eea) = ea `mappend` joinE eea
-
-instance MonadPlus Event where { mzero = mempty; mplus = mappend }
-
-instance Monad Reactive where
- return = pure
- r >>= h = joinR (fmap h r)
-
--- | Switch between reactive values.
-switcher :: Reactive a -> Event (Reactive a) -> Reactive a
-r `switcher` e = joinR (r `stepper` e)
-
--- Reactive 'join'
-joinR :: Reactive (Reactive a) -> Reactive a
-joinR ((a `Stepper` Event fut) `Stepper` e'@(Event fut')) =
- a `stepper` Event fut''
- where
- -- If fut arrives first, switch and continue waiting for e'.
- -- If fut' arrives first, abandon fut and keep switching with new
- -- reactive values from fut'.
- fut'' = fmap (`switcher` e') fut `mappend` fmap join fut'
-
--- | Make an event and a sink for feeding the event. Each value sent to
--- the sink becomes an occurrence of the event.
-mkEvent :: IO (Event a, Sink a)
-mkEvent = do (fut,snk) <- newFuture
- -- remember how to save the next occurrence.
- r <- newIORef snk
- return (Event fut, writeTo r)
- where
- -- Fill in an occurrence while preparing for the next one
- writeTo r a = do snk <- readIORef r
- (fut',snk') <- newFuture
- writeIORef r snk'
- snk (a `stepper` Event fut')
-
--- | Tracing variant of 'mkEvent'
-mkEventTrace :: (a -> String) -> IO (Event a, Sink a)
-mkEventTrace shw = second tr <$> mkEvent
- where
- tr snk = (putStrLn.shw) `mappend` snk
-
--- | Show specialization of 'mkEventTrace'
-mkEventShow :: Show a => String -> IO (Event a, Sink a)
-mkEventShow str = mkEventTrace ((str ++).(' ':).show)
-
--- | Run an event in a new thread.
-forkE :: Event (IO b) -> IO ThreadId
-forkE = forkIO . runE
-
--- | Subscribe a listener to an event. Wrapper around 'forkE' and 'fmap'.
-subscribe :: Event a -> Sink a -> IO ThreadId
-subscribe e snk = forkE (snk <$> e)
-
--- | Run an event in the current thread.
-runE :: Event (IO b) -> IO a
-runE (Event fut) = do act `Stepper` e' <- force fut
- act
- runE e'
-
--- | Run a reactive value in a new thread. The initial action happens in
--- the current thread.
-forkR :: Reactive (IO b) -> IO ThreadId
-forkR (act `Stepper` e) = act >> forkE e
-
-
-{--------------------------------------------------------------------
- Event extras
---------------------------------------------------------------------}
-
--- | Accumulating event, starting from an initial value and a
--- update-function event. See also 'accumR'.
-accumE :: a -> Event (a -> a) -> Event a
-accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'
-
--- | Like 'scanl' for events. See also 'scanlR'.
-scanlE :: (a -> b -> a) -> a -> Event b -> Event a
-scanlE f a e = a `accumE` (flip f <$> e)
-
--- | Accumulate values from a monoid-valued event. Specialization of
--- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidR'.
-monoidE :: Monoid o => Event o -> Event o
-monoidE = scanlE mappend mempty
-
--- | Pair each event value with the previous one, given an initial value.
-withPrevE :: Event a -> Event (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 :: u -> Unop (u,u)
- shift new (_,old) = (old,new)
- combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
- combineMaybes = uncurry (liftA2 (,))
-
--- | Count occurrences of an event, remembering the occurrence values.
--- See also 'countE_'.
-countE :: Num n => Event b -> Event (b,n)
-countE = scanlE h (b0,0)
- where
- b0 = error "withCountE: no initial value"
- h (_,n) b = (b,n+1)
-
--- | Count occurrences of an event, forgetting the occurrence values. See
--- also 'countE'. See also 'countR'.
-countE_ :: Num n => Event b -> Event n
-countE_ e = snd <$> countE e
-
--- | Difference of successive event occurrences.
-diffE :: Num n => Event n -> Event n
-diffE e = uncurry (-) <$> withPrevE e
-
--- | Snapshot a reactive value whenever an event occurs.
-snapshot :: Event a -> Reactive b -> Event (a,b)
-e `snapshot` r = joinMaybes $ e `snap` r
-
--- This variant of 'snapshot' yields 'Just's when @e@ happens and
--- 'Nothing's when @r@ changes.
-snap :: forall a b. Event a -> Reactive b -> Event (Maybe (a,b))
-e@(Event ve) `snap` r@(b `Stepper` Event vr) =
- Event ((g <$> ve) `mappend` (h <$> vr))
- where
- -- When e occurs, produce a pair, and start snapshotting the old
- -- reactive value with the new event.
- g :: Reactive a -> Reactive (Maybe (a,b))
- g (a `Stepper` e') = Just (a,b) `stepper` (e' `snap` r)
- -- When r changes, produce no pair, and start snapshotting the new
- -- reactive value with the old event.
- h :: Reactive b -> Reactive (Maybe (a,b))
- h r' = Nothing `stepper` (e `snap` r')
-
--- Introducing Nothing above allows the mappend to commit to the RHS.
-
--- | Like 'snapshot' but discarding event data (often @a@ is @()@).
-snapshot_ :: Event a -> Reactive b -> Event b
-e `snapshot_` src = snd <$> (e `snapshot` src)
-
--- | Filter an event according to whether a boolean source is true.
-whenE :: Event a -> Reactive Bool -> Event a
-whenE e = joinMaybes . fmap h . snapshot e
- where
- h (a,True) = Just a
- h (_,False) = Nothing
-
--- | Just the first occurrence of an event.
-once :: Event a -> Event a
-once = inEvent $ fmap $ pure . rInit
-
--- | Tracing of events.
-traceE :: (a -> String) -> Unop (Event a)
-traceE shw = fmap (\ a -> trace (shw a) a)
-
-
--- | Make an extensible event. The returned sink is a way to add new
--- events to mix. You can often use '(>>=)' or 'join' instead. Warning:
--- this function might be removed at some point.
-eventX :: IO (Event a, Sink (Event a))
-eventX = first join <$> mkEvent
-
-
-{--------------------------------------------------------------------
- Reactive extras
---------------------------------------------------------------------}
-
-mkReactive :: a -> IO (Reactive a, Sink a)
-mkReactive a0 = first (a0 `stepper`) <$> mkEvent
-
--- | Reactive value from an initial value and an updater event. See also
--- 'accumE'.
-accumR :: a -> Event (a -> a) -> Reactive a
-a `accumR` e = a `stepper` (a `accumE` e)
-
--- | Like 'scanl' for reactive values. See also 'scanlE'.
-scanlR :: (a -> b -> a) -> a -> Event b -> Reactive 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 :: Monoid a => Event a -> Reactive a
-monoidR = scanlR mappend mempty
-
--- | 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 :: Event a -> Event b -> Reactive (Maybe a)
-maybeR get lose =
- Nothing `stepper` (fmap Just get `mappend` replace Nothing lose)
-
--- | Flip-flopping source. Turns true when @ea@ occurs and false when
--- @eb@ occurs.
-flipFlop :: Event a -> Event b -> Reactive Bool
-flipFlop ea eb =
- False `stepper` (replace True ea `mappend` replace False eb)
-
--- TODO: generalize 'maybeR' & 'flipFlop'. Perhaps using 'Monoid'.
--- Note that Nothing and (Any False) are mempty.
-
--- | Count occurrences of an event. See also 'countE'.
-countR :: Num n => Event a -> Reactive n
-countR e = 0 `stepper` countE_ e
-
--- | Tracing of reactive values
-traceR :: (a -> String) -> Unop (Reactive a)
-traceR shw (a `Stepper` e) = a `Stepper` traceE shw e
-
-
-{--------------------------------------------------------------------
- Other instances
---------------------------------------------------------------------}
-
--- Standard instances
-instance Pair Reactive where pair = liftA2 (,)
-instance (Monoid_f f) => Monoid_f (Reactive :. f) where
- { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
-instance Pair f => Pair (Reactive :. f) where pair = apPair
-
-instance Unpair Reactive where {pfst = fmap fst; psnd = fmap snd}
-
--- Standard instances
-instance Monoid_f Event where
- { mempty_f = mempty ; mappend_f = mappend }
-instance Monoid ((Event :. f) a) where
- { mempty = O mempty; mappend = inO2 mappend }
-instance Monoid_f (Event :. f) where
- { mempty_f = mempty ; mappend_f = mappend }
-instance Copair f => Pair (Event :. f) where
- pair = copair
-
--- Standard instance for functors
-instance Unpair Event where {pfst = fmap fst; psnd = fmap snd}
-
-
-
-{--------------------------------------------------------------------
- Reactive behaviors over continuous time
---------------------------------------------------------------------}
-
--- | Time for continuous behaviors
-type Time = Double
-
--- | Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in
--- a type composition to get 'Functor' and 'Applicative' for free.
-type ReactiveB = Reactive :. Fun Time
-
-
-{--------------------------------------------------------------------
- To be moved elsewhere
---------------------------------------------------------------------}
-
--- | Replace a functor value with a given one.
-replace :: Functor f => b -> f a -> f b
-replace b = fmap (const b)
-
--- | Forget a functor value, replace with @()@
-forget :: Functor f => f a -> f ()
-forget = replace ()
-
--- | Convenient alias for dropping parentheses.
-type Action = IO ()
-
--- | Value sink
-type Sink a = a -> Action
-
--- | Pass through @Just@ occurrences.
-joinMaybes :: MonadPlus m => m (Maybe a) -> m a
-joinMaybes = (>>= maybe mzero return)
-
--- | Pass through values satisfying @p@.
-filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
-filterMP p m = joinMaybes (liftM f m)
- where
- f a | p a = Just a
- | otherwise = Nothing
-
--- Alternatively:
--- filterMP p m = m >>= guarded p
--- where
--- guarded p x = guard (p x) >> return x
diff --git a/src/Data/SEvent.hs b/src/Data/SEvent.hs
deleted file mode 100755
index 36b0f2c..0000000
--- a/src/Data/SEvent.hs
+++ /dev/null
@@ -1,168 +0,0 @@
-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving
- , FlexibleInstances, FlexibleContexts, TypeSynonymInstances
- , MultiParamTypeClasses
- #-}
-
-----------------------------------------------------------------------
--- |
--- Module : Data.SEvent
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Denotational semantics for events
-----------------------------------------------------------------------
-
-module Data.SEvent
- (
- -- * Event primitives
- Event'(..), accumE
- ) where
-
-import Data.Monoid
-import Control.Applicative
-import Control.Monad
-
--- TypeCompose
-import Control.Compose (Binop,DistribM(..))
-
-import Data.SFuture
-
-
-{----------------------------------------------------------
- Event primitives
-----------------------------------------------------------}
-
--- | Generalized 'Event' over arbitrary (ordered) time type. See also
--- 'Event\''.
-newtype Event' t a = E { unE :: [Future t a] }
-
--- | Apply a unary function within the 'Ascend' constructor.
-inE :: ([Future t a] -> [Future t b]) -> (Event' t a -> Event' t b)
-inE f = E . f . unE
-
--- | Apply a binary function within the 'E' constructor.
-inE2 :: ([Future t a] -> [Future t b] -> [Future t c])
- -> (Event' t a -> Event' t b -> Event' t c)
-inE2 f = inE . f . unE
-
-
--- Note: the semantics of Applicative and Monad are not consistent with
---
--- type Event = [] :. Fut
---
--- because that composition would combine future values with []-style
--- backtracking instead of temporal interleaving.
---
--- However, maybe there's a []-wrapping newtype I can use instead.
-
-instance Ord t => Monoid (Event' t a) where
- mempty = E []
- mappend = inE2 merge
-
-instance Functor (Event' t) where
- fmap f = inE ((fmap.fmap) f)
-
-instance Ord t => Applicative (Event' t) where
- pure = return
- (<*>) = ap
-
-instance Ord t => Monad (Event' t) where
- return a = E ((return.return) a)
- e >>= f = joinE (f <$> e)
-
--- This MonadPlus instance could go in EventExtras, but it would be an
--- orphan there.
-instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }
-
--- For monad compositions.
--- We'll need this instance in MEvent. It'd be an orphan there.
-instance Ord t => DistribM (Event' t) Maybe where
- -- distribM :: Maybe (Event' t b) -> Event' t (Maybe b)
- distribM = maybe mempty (fmap Just)
-
--- | Equivalent to 'join' for 'Event'. More efficient?
-joinE :: Ord t => Event' t (Event' t a) -> Event' t a
-joinE = inE $ concatF . (fmap.fmap) unE
-
--- Derivation:
---
--- Event (Event a)
--- --> [Fut (Event a)] -- unE
--- --> [Fut [Fut a]] -- (fmap.fmap) unE
--- --> [Fut a] -- concatF
--- --> Event a -- E
-
--- My previous attempt:
-
--- joinE :: Ord t => Event' t (Event' t a) -> Event' t a
--- joinE = mconcat . fmap (E . fmap join . sequenceF . fmap unE) . unE
---
--- Derivation:
---
--- Event (Event a)
--- --> [Fut (Event a)] -- unE
--- --> [Fut [Fut a]] -- (fmap.fmap) unE
--- --> [[Fut (Fut a)]] -- fmap sequenceF
--- --> [[Fut a]] -- (fmap.fmap) join
--- --> [Event a] -- fmap E
--- --> Event a -- mconcat
-
--- I don't think joinE works as I want. The join on Fut makes sure that
--- the inner occurrences follow the outer, but I don't think fact is
--- visible to the implementation. Also, note that the mconcat could have
--- an infinite number of lists to merge.
-
-flatFFs :: Ord t => Future t [Future t a] -> [Future t a]
-flatFFs = fmap join . sequenceF
-
-concatF :: Ord t => [Future t [Future t a]] -> [Future t a]
-concatF = futVal . foldr mergeF (pure [])
-
--- Binary merge. The second argument is required to have the property
--- that sub-futures are all at least as late as the containing future.
--- The result is then guaranteed to have the same property, which allows
--- use of futVal instead of flatFFs in concatF.
-mergeF :: Ord t => Binop (Future t [Future t a])
-ffa `mergeF` Future (tb,futbs) =
- -- First the a values before tb, then interleave the rest of the a
- -- values with the b values.
- Future (futTime ffa, prefa ++ (suffa `merge` futbs))
- where
- (prefa,suffa) = span ((<= tb).futTime) (flatFFs ffa)
-
--- TODO: try out a more efficient version of mergeF that doesn't use
--- (++). Idea: add a span to Data.DList and use it. Efficient &
--- elegant.
-
-
--- | Accumulating event, starting from an initial value and a
--- update-function event. See also 'accumR'.
-accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a
-accumE a = inE $ \ futfs -> accum (pure a) (fmap (<*>) futfs)
-
-
-{--------------------------------------------------------------------
- Misc utilities
---------------------------------------------------------------------}
-
--- | Merge two ordered lists into an ordered list.
-merge :: Ord a => [a] -> [a] -> [a]
-[] `merge` vs = vs
-us `merge` [] = us
-us@(u:us') `merge` vs@(v:vs') =
- if u <= v then
- u : (us' `merge` vs )
- else
- v : (us `merge` vs')
-
-
-accum :: a -> [a->a] -> [a]
-accum _ [] = []
-accum a (f:fs) = a' : accum a' fs where a' = f a
-
--- or
--- accum a = tail . scanl (flip ($)) a
diff --git a/src/Data/SFuture.hs b/src/Data/SFuture.hs
deleted file mode 100755
index ba4bed9..0000000
--- a/src/Data/SFuture.hs
+++ /dev/null
@@ -1,195 +0,0 @@
--- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS -Wall -fno-warn-orphans #-}
--- For ghc-6.6 compatibility
-{-# OPTIONS_GHC -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module : Data.SFuture
--- Copyright : (c) Conal Elliott 2007
--- License : LGPL
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- A sort of semantic prototype for functional /futures/, roughly as
--- described at <http://en.wikipedia.org/wiki/Futures_and_promises>.
---
--- A /future/ is a value that will become knowable only later. This
--- module gives a way to manipulate them functionally. For instance,
--- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable.
---
--- Primitive futures can be things like /the value of the next key you
--- press/, or /the value of LambdaPix stock at noon next Monday/.
---
--- Composition is via standard type classes: 'Ord', 'Functor',
--- 'Applicative', 'Monad', and 'Monoid'. Some comments on the 'Future'
--- instances of these classes:
---
--- * 'Ord': @a `min` b@ is whichever of @a@ and @b@ is knowable first. @a
--- `max` b@ is whichever of @a@ and @b@ is knowable last.
---
--- * Monoid: 'mempty' is a future that never becomes knowable. 'mappend'
--- is the same as 'min'.
---
--- * 'Functor': apply a function to a future. The result is knowable when
--- the given future is knowable.
---
--- * 'Applicative': 'pure' gives value knowable since the beginning of
--- time. '(\<*\>)' applies a future function to a future argument.
--- Result available when /both/ are available, i.e., it becomes knowable
--- when the later of the two futures becomes knowable.
---
--- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@
--- cascades futures. 'join' resolves a future future value into a
--- future value.
---
--- Futures are parametric over /time/ as well as /value/ types. The time
--- parameter can be any ordered type.
---
--- Please keep in mind that this module specifies the interface and
--- semantics, rather than a useful implementation. See "Data.Future" for
--- an implementation that nearly implements the semantics described here.
---
--- On second thought, I'm experimenting with using this module in an
--- usable implementation of events. See Data.MEvent.
-----------------------------------------------------------------------
-
-module Data.SFuture
- (
- -- * Time & futures
- Time, Future(..), futTime, futVal, sequenceF
- -- * To go elsewhere
- , Max(..), Min(..), AddBounds(..)
- ) where
-
-import Data.Monoid (Monoid(..))
-import Control.Applicative (Applicative(..))
-import Data.Function (on)
-
-
-{----------------------------------------------------------
- Time and futures
-----------------------------------------------------------}
-
--- | Time of some event occurrence, which can be any @Ord@ type. In an
--- actual implementation, we would not usually have access to the time
--- value until (slightly after) that time. Extracting the actual time
--- would block until the time is known. The added bounds represent
--- -Infinity and +Infinity. Pure values have time minBound (-Infinity),
--- while eternally unknowable values (non-occurring events) have time
--- maxBound (+Infinity).
-type Time t = Max (AddBounds t)
-
--- | A future value of type @a@ with time type @t@. Semantically, just a
--- time\/value pair, but those values would not be available until
--- 'force'd, which could block.
-newtype Future t a = Future { unFuture :: (Time t, a) }
- deriving (Functor, Applicative, Monad, Show)
-
--- The 'Applicative' instance relies on the 'Monoid' instance of 'Max'.
-
--- | A future's time
-futTime :: Future t a -> Time t
-futTime = fst . unFuture
-
--- | A future's value
-futVal :: Future t a -> a
-futVal = snd . unFuture
-
-
--- -- The Monoid instance picks the earlier future
--- instance Ord t => Monoid (Future t a) where
--- mempty = Future (maxBound, error "it'll never happen, buddy")
--- fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) =
--- if t <= t' then fut else fut'
-
--- or:
-
-
-instance Eq (Future t a) where
- (==) = error "sorry, no (==) for futures"
-
-instance Ord t => Ord (Future t a) where
- (<=) = (<=) `on` futTime
- -- We could leave 'min' to the default in terms of '(<=)', but the
- -- following can yield partial time info, as much as allowed by the time
- -- parameter type @t@ and its 'min'.
- Future (s,a) `min` Future (t,b) =
- Future (s `min` t, if s <= t then a else b)
-
--- For some choices of @t@, there may be an efficient combination of 'min'
--- and '(<=)'. In particular, 'Improving' has 'minI'.
-
-instance Ord t => Monoid (Future t a) where
- mempty = Future (maxBound, error "it'll never happen, buddy")
- mappend = min
-
--- 'sequenceF' is like 'sequenceA' from "Data.Traversable". However,
--- the @Traversable@ class assumes @Foldable@, which I'm not confident
--- how to implement usefully. (I could of course just strip off the
--- 'Future' constructor and the time. Why is Foldable required?
-
--- | Make a future container into a container of futures.
-sequenceF :: Functor f => Future t (f a) -> f (Future t a)
-sequenceF (Future (tt, f)) = fmap (Future . ((,) tt)) f
-
-
-
-{----------------------------------------------------------
- To go elsewhere
-----------------------------------------------------------}
-
--- For Data.Monoid:
-
--- | Ordered monoid under 'max'.
-newtype Max a = Max { getMax :: a }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance (Ord a, Bounded a) => Monoid (Max a) where
- mempty = Max minBound
- Max a `mappend` Max b = Max (a `max` b)
-
--- | Ordered monoid under 'min'.
-newtype Min a = Min { getMin :: a }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance (Ord a, Bounded a) => Monoid (Min a) where
- mempty = Min maxBound
- Min a `mappend` Min b = Min (a `min` b)
-
--- I have a niggling uncertainty about the 'Ord' & 'Bounded' instances for
--- @Min a@? Is there a reason flip the @a@ ordering instead of preserving
--- it?
-
--- For Control.Monad.Instances
-
--- Equivalent to the Monad Writer instance.
--- import Data.Monoid
-instance Monoid o => Monad ((,) o) where
- return = pure
- (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a
-
--- Alternatively,
--- m >>= f = join (fmap f m)
--- where
--- join ((o, (o',a))) = (o `mappend` o', a)
--- Or even,
--- (o,a) >>= f = (o,id) <*> f a
---
--- I prefer the join version, because it's the standard (>>=)-via-join,
--- plus a very simple definition for join. Too bad join isn't a method of
--- Monad, with (>>=) and join defined in terms of each other. Why isn't
--- it? Probably because Monad isn't derived from Functor. Was that an
--- oversight?
-
--- Where to put this definition? Prelude?
-
--- | Wrap a type into one having new least and greatest elements,
--- preserving the existing ordering.
-data AddBounds a = MinBound | NoBound a | MaxBound
- deriving (Eq, Ord, Read, Show)
-
-instance Bounded (AddBounds a) where
- minBound = MinBound
- maxBound = MaxBound
diff --git a/src/Data/SImproving.hs b/src/Data/SImproving.hs
deleted file mode 100755
index eb4e0e5..0000000
--- a/src/Data/SImproving.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# OPTIONS -Wall #-}
-----------------------------------------------------------------------
--- |
--- Module : Data.Improving
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy
--- in an Abstract Data Type with Deterministic Semantics\".
---
--- TODO: an efficient, referentially transparent, side-effecting version.
-----------------------------------------------------------------------
-
-module Data.Improving
- (
- Improving(..), exact
- -- , Improves, merge
- -- , Future(..)
- ) where
-
-import Data.Function (on)
-
--- | Progressive information about a value (e.g., a time)
-data Improving t = AtLeast t (Improving t) | Exactly t deriving Show
-
--- | Extract an exact value from an improving value
-exact :: Improving t -> t
-exact (AtLeast _ u) = exact u
-exact (Exactly t) = t
-
-instance Eq t => Eq (Improving t) where
- (==) = (==) `on` exact
-
-instance Ord t => Ord (Improving t) where
- Exactly s `compare` Exactly t = s `compare` t
- AtLeast s u' `compare` v@(Exactly t) =
- if s > t then GT else u' `compare` v
- u@(Exactly s) `compare` AtLeast t v' =
- if s < t then LT else u `compare` v'
- u@(AtLeast s u') `compare` v@(AtLeast t v') =
- -- move forward where we know less
- if s <= t then
- u' `compare` v
- else
- u `compare` v'
-
- Exactly s `min` Exactly t = Exactly (s `min` t)
- AtLeast s u' `min` v@(Exactly t) =
- if s > t then v else u' `min` v
- u@(Exactly s) `min` AtLeast t v' =
- if s < t then u else u `min` v'
- u@(AtLeast s u') `min` v@(AtLeast t v') =
- -- move forward where we know less
- if s <= t then
- u' `min` v
- else
- u `min` v'
diff --git a/src/Data/SReactive.hs b/src/Data/SReactive.hs
deleted file mode 100755
index 3a95baf..0000000
--- a/src/Data/SReactive.hs
+++ /dev/null
@@ -1,169 +0,0 @@
-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}
-----------------------------------------------------------------------
--- |
--- Module : Data.SReactive
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Simple, semantics-based reactive values
-----------------------------------------------------------------------
-
-module Data.SReactive
- (
- -- * Primitives
- Reactive'(..), stepper
- , joinR
- -- * Extras (defined via primitives)
- , Reactive
- , switcher, snapshot, snapshot_, whenE
- , accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR
- ) where
-
-import Control.Applicative
-import Control.Monad
-import Data.Monoid
-
--- TypeCompose
-import Control.Compose (Unop)
-import Data.Pair (Pair(..),pairEdit)
-
-import Data.EventExtras
-import Data.Improving
-
-
-{----------------------------------------------------------
- Primitives
-----------------------------------------------------------}
-
-data Reactive' t a =
- Stepper {
- rInit :: a -- ^ initial value
- , rEvent :: Event' t a -- ^ waiting for event
- }
-
--- | Reactive value from an initial value and a new-value event.
-stepper :: a -> Event' t a -> Reactive' t a
-stepper = Stepper
-
-
-instance Ord t => Pair (Reactive' t) where
- -- pair :: Reactive' t a -> Reactive' t b -> Reactive' t (a,b)
- (c `Stepper` ce) `pair` (d `Stepper` de) =
- (c,d) `accumR` pairEdit (ce,de)
-
-instance Functor (Reactive' t) where
- fmap f (a `Stepper` e) = f a `stepper` fmap f e
-
-instance Ord t => Applicative (Reactive' t) where
- pure a = a `stepper` mempty
- -- Standard definition. See 'Pair'.
- rf <*> rx = uncurry ($) <$> (rf `pair` rx)
-
--- A wonderful thing about the <*> definition for Reactive' t is that it
--- automatically caches the previous value of the function or argument
--- when the argument or function changes.
-
-instance Ord t => Monad (Reactive' t) where
- return = pure
- r >>= f = joinR (f <$> r)
-
--- | Reactive' t 'join' (equivalent to 'join' but slightly more efficient, I think)
-joinR :: Ord t => Reactive' t (Reactive' t a) -> Reactive' t a
-joinR ((a `Stepper` e) `Stepper` er) =
- a `stepper` (e `mappend` join (rToE <$> er))
-
--- | Turn a reactive value into an event, given a time for the initial
--- occurrence.
-rToE :: Ord t => Reactive' t a -> Event' t a
-rToE (a `Stepper` e) = pure a `mappend` e
-
--- e :: Event' t a
--- er :: Event' t (Reactive' t a)
---
--- rToE <$> er ::: Event' t (Event' t a)
--- join (rToE <$> er) ::: Event' t a
-
--- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
--- didn't.
-snap :: forall a b t. Ord t =>
- Event' t a -> Reactive' t b -> Event' t (Maybe a, b)
-ea `snap` (b0 `Stepper` eb) =
- (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)
-
-
-{----------------------------------------------------------
- Extras (defined via primitives)
-----------------------------------------------------------}
-
-type Reactive = Reactive' (Improving Double)
-
--- | Snapshot a reactive value whenever an event occurs.
-snapshot :: Ord t => Event' t a -> Reactive' t b -> Event' t (a,b)
-e `snapshot` r = joinMaybes $ fmap f (e `snap` r)
- where
- f (Nothing,_) = Nothing
- f (Just a ,b) = Just (a,b)
-
--- | Switch between reactive values.
-switcher :: Ord t => Reactive' t a -> Event' t (Reactive' t a) -> Reactive' t a
-r `switcher` e = joinR (r `stepper` e)
-
--- | Like 'snapshot' but discarding event data (often @a@ is @()@).
-snapshot_ :: Ord t => Event' t a -> Reactive' t b -> Event' t b
-e `snapshot_` src = snd <$> (e `snapshot` src)
-
--- | Filter an event according to whether a boolean source is true.
-whenE :: Ord t => Event' t a -> Reactive' t Bool -> Event' t a
-whenE e = joinMaybes . fmap h . snapshot e
- where
- h (a,True) = Just a
- h (_,False) = Nothing
-
-
--- | Reactive' t value from an initial value and an updater event. See also
--- 'accumE'.
-accumR :: Ord t => a -> Event' t (a -> a) -> Reactive' t a
-a `accumR` e = a `stepper` (a `accumE` e)
-
--- | Like 'scanl' for reactive values. See also 'scanlE'.
-scanlR :: Ord t => (a -> b -> a) -> a -> Event' t b -> Reactive' 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) => Event' t a -> Reactive' t a
-monoidR = scanlR mappend mempty
-
--- | 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 => Event' t a -> Event' t b -> Reactive' t (Maybe a)
-maybeR get lose =
- Nothing `stepper` (fmap Just get `mappend` (Nothing <$ lose))
-
--- | Flip-flopping source. Turns true when @ea@ occurs and false when
--- @eb@ occurs.
-flipFlop :: Ord t => Event' t a -> Event' t b -> Reactive' t Bool
-flipFlop ea eb =
- False `stepper` ((True <$ ea) `mappend` (False <$ eb))
-
--- TODO: generalize 'maybeR' & 'flipFlop'. Perhaps using 'Monoid'.
--- Note that Nothing and (Any False) are mempty.
-
--- | Count occurrences of an event. See also 'countE'.
-countR :: (Ord t, Num n) => Event' t a -> Reactive' t n
-countR e = 0 `stepper` countE_ e
-
--- | Tracing of reactive values
-traceR :: (a -> String) -> Unop (Reactive' t a)
-traceR shw (a `Stepper` e) = a `Stepper` traceE shw e
-
diff --git a/src/Data/Unamb.hs b/src/Data/Unamb.hs
deleted file mode 100755
index 1be8ff4..0000000
--- a/src/Data/Unamb.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE RecursiveDo #-}
-----------------------------------------------------------------------
--- |
--- Module : Data.Unamb
--- Copyright : (c) Conal Elliott 2008
--- License : BSD3
---
--- Maintainer : conal@conal.net
--- Stability : experimental
---
--- Unambiguous choice
-----------------------------------------------------------------------
-
-module Data.Unamb
- (
- unamb, amb, race, assuming
- ) where
-
--- For hang
-import Control.Monad (forever)
-import System.IO.Unsafe
-
--- For unamb
-import Control.Concurrent
-import Control.Exception (evaluate)
-
-
--- | Unambiguous choice operator. Equivalent to the ambiguous choice
--- operator, but with arguments restricted to be equal where not bottom,
--- so that the choice doesn't matter. See also 'amb'.
-unamb :: a -> a -> a
-a `unamb` b = unsafePerformIO (a `amb` b)
-
-
--- | Ambiguous choice operator. Yield either value. Evaluates in
--- separate threads and picks whichever finishes first. See also
--- 'unamb' and 'race'.
-amb :: a -> a -> IO a
-a `amb` b = evaluate a `race` evaluate b
-
--- | Race two actions against each other in separate threads, and pick
--- whichever finishes first. See also 'amb'.
-race :: IO a -> IO a -> IO a
-a `race` b =
- -- Evaluate a and b in concurrent threads. Whichever thread finishes
- -- first kill the other thread.
- do v <- newEmptyMVar -- to hold a or b
- lock <- newEmptyMVar -- to avoid double-kill
- -- Evaluate one value and kill the other.
- let run io tid = forkIO $ do x <- io
- putMVar lock ()
- killThread tid
- putMVar v x
- mdo ta <- run a tb
- tb <- run b ta
- return ()
- readMVar v
-
--- Without using unsafePerformIO, is there a way to define a
--- non-terminating but non-erroring pure value that consume very little
--- resources while not terminating?
-
--- | Never yield an answer. Like 'undefined' or 'error "whatever"', but
--- don't raise an error, and don't consume computational resources.
-hang :: a
-hang = unsafePerformIO hangIO
-
--- | Block forever
-hangIO :: IO a
-hangIO = do -- putStrLn "warning: blocking forever."
- -- Any never-terminating computation goes here
- -- This one can yield an exception "thread blocked indefinitely"
- -- newEmptyMVar >>= takeMVar
- -- sjanssen suggests this alternative:
- forever $ threadDelay maxBound
- -- forever's return type is (), though it could be fully
- -- polymorphic. Until it's fixed, I need the following line.
- return undefined
-
-
--- | Yield a value if a condition is true. Otherwise wait forever.
-assuming :: Bool -> a -> a
-assuming c a = if c then a else hang
diff --git a/src/Examples.hs b/src/Examples.hs
index 28ccef2..08497e5 100755
--- a/src/Examples.hs
+++ b/src/Examples.hs
@@ -30,7 +30,7 @@ import Control.Compose ((:.)(..), inO,inO2)
import Data.Title
-- Reactive
-import Data.Reactive
+import Reactive.Reactive
{--------------------------------------------------------------------
diff --git a/src/FRP/Reactive.hs b/src/FRP/Reactive.hs
new file mode 100755
index 0000000..aaf791e
--- /dev/null
+++ b/src/FRP/Reactive.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- A library for programming with functional reactive behaviors.
+----------------------------------------------------------------------
+
+module FRP.Reactive
+ (
+ -- * Events
+ TimeT, ITime
+ , EventG, Event
+ , accumE
+ , withTimeE
+ , pairE, scanlE, monoidE
+ , stateE, stateE_, countE, countE_, diffE
+ , withPrevE, withPrevEWith
+ , whenE, eitherE
+ -- ** More esoteric
+ , listE, atTimes, atTime, once
+ , firstRestE, firstE, restE
+ , withRestE, untilE
+ , splitE, switchE
+ -- ** Useful with events.
+ , joinMaybes, filterMP
+ -- * Behaviors
+ , BehaviorG, Behavior
+ , time
+ , stepper, switcher --, select
+ , snapshotWith, snapshot, snapshot_
+ , accumB
+ , scanlB, monoidB, maybeB, flipFlop, countB
+ , sumB, integral
+ ) where
+
+-- Reactive.Reactive exports reactive values as well. Filter them out.
+
+import FRP.Reactive.Reactive hiding
+ (stepper,switcher,snapshotWith,snapshot,snapshot_,flipFlop,integral)
+import FRP.Reactive.Behavior
diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs
new file mode 100755
index 0000000..fe2983d
--- /dev/null
+++ b/src/FRP/Reactive/Behavior.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Behavior
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Reactive behaviors (continuous time)
+----------------------------------------------------------------------
+
+module FRP.Reactive.Behavior
+ (
+ BehaviorG, Behavior
+ , time
+ , stepper, switcher --, select
+ , snapshotWith, snapshot, snapshot_
+ , accumB
+ , scanlB, monoidB, maybeB, flipFlop, countB
+ , sumB, integral
+ ) where
+
+import Data.Monoid (Monoid)
+import Control.Applicative (Applicative,pure,(<$>))
+
+import Data.VectorSpace
+
+import qualified FRP.Reactive.Reactive as R
+import FRP.Reactive.Reactive (TimeT, ITime, Event, withTimeE, diffE)
+import FRP.Reactive.Fun
+import FRP.Reactive.Internal.Behavior
+
+
+-- | Time-specialized behaviors.
+-- Note: The signatures of all of the behavior functions can be generalized. Is
+-- the interface generality worth the complexity?
+type Behavior = BehaviorG ITime TimeT
+
+-- | The identity generalized behavior. Has value @t@ at time @t@.
+time :: Behavior TimeT
+time = beh (pure (fun id))
+
+-- Turn a reactive value into a discretly changing behavior.
+rToB :: R.Reactive a -> Behavior a
+rToB = beh . fmap pure
+
+-- Then use 'rToB' to promote reactive value functions to behavior
+-- functions.
+
+-- | 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
+
+-- Suggested by Robin Green:
+
+-- stepper = select pure
+
+-- -- | Use a key event to key into a behaviour-valued function
+-- select :: (a -> Behavior b) -> a -> Event a -> Behavior b
+-- select f a e = f a `switcher` (f <$> e)
+
+-- Looking for a more descriptive name.
+
+-- | Switch between behaviors.
+switcher :: Behavior a -> Event (Behavior a) -> Behavior a
+b `switcher` eb = beh (unb b `R.switcher` (unb <$> eb))
+
+-- | Snapshots a behavior whenever an event occurs and combines the values
+-- using the combining function passed.
+snapshotWith :: (a -> b -> c) -> Event a -> Behavior b -> Event c
+snapshotWith h e b = f <$> (withTimeE e `R.snapshot` unb b)
+ where
+ f ((a,t),tfun) = h a (tfun `apply` t)
+
+-- | Snapshot a behavior whenever an event occurs. See also 'snapshotWith'.
+snapshot :: Event a -> Behavior b -> Event (a,b)
+snapshot = snapshotWith (,)
+
+-- Alternative implementations:
+-- snapshotWith c e b = uncurry c <$> snapshot e b
+-- snapshotWith c = (fmap.fmap.fmap) (uncurry c) snapshot
+
+-- | Like 'snapshot' but discarding event data (often @a@ is '()').
+snapshot_ :: Event a -> Behavior b -> Event b
+snapshot_ = snapshotWith (flip const)
+
+-- Alternative implementations
+-- e `snapshot_` src = snd <$> (e `snapshot` src)
+-- snapshot_ = (fmap.fmap.fmap) snd snapshot
+
+-- | 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
+
+-- | Like 'scanl' for behaviors. See also 'scanlE'.
+scanlB :: (a -> b -> a) -> a -> Event b -> Behavior a
+scanlB = (fmap.fmap.fmap) rToB R.scanlR
+
+-- | Accumulate values from a monoid-valued event. Specialization of
+-- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'.
+monoidB :: Monoid a => Event a -> Behavior a
+monoidB = fmap rToB R.monoidR
+
+-- | Like 'sum' for behaviors.
+sumB :: VectorSpace v s => Event v -> Behavior v
+sumB = fmap 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
+
+-- | 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
+
+-- | Count occurrences of an event. See also 'countE'.
+countB :: Num n => Event a -> Behavior n
+countB = fmap rToB R.countR
+
+-- | Euler integral.
+integral :: VectorSpace v TimeT =>
+ Event () -> Behavior v -> Behavior v
+integral t = sumB . snapshotWith (*^) (diffE (t `snapshot_` time))
+
+-- TODO: find out whether this integral works recursively. If not, then
+-- fix the implementation, rather than changing the semantics. (No
+-- "delayed integral".)
+--
+-- Early experiments suggest that recursive integration gets stuck.
+-- Investigate.
diff --git a/src/FRP/Reactive/Fun.hs b/src/FRP/Reactive/Fun.hs
new file mode 100755
index 0000000..7b26262
--- /dev/null
+++ b/src/FRP/Reactive/Fun.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Fun
+-- Copyright : (c) Conal Elliott 2007
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Functions, with constant functions optimized. With instances of
+-- 'Functor', 'Applicative', 'Monad', and 'Arrow'
+----------------------------------------------------------------------
+
+module FRP.Reactive.Fun (Fun, fun, apply, batch) where
+
+import Data.Monoid (Monoid(..))
+import Control.Applicative (Applicative(..),liftA)
+#if __GLASGOW_HASKELL__ >= 609
+import Control.Category
+import Prelude hiding ((.), id)
+#endif
+import Control.Arrow
+#if __GLASGOW_HASKELL__ < 610
+ hiding (pure)
+#endif
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+import Test.QuickCheck.Applicative ()
+
+import Text.Show.Functions ()
+
+import FRP.Reactive.Internal.Fun
+
+
+-- TODO: write RULE for fun . const = K
+fun :: (t -> a) -> Fun t a
+fun = Fun
+
+instance (Arbitrary a,Arbitrary b) => Arbitrary (Fun a b) where
+ arbitrary = oneof [liftA K arbitrary, liftA Fun arbitrary]
+ coarbitrary (K a) = variant 0 . coarbitrary a
+ coarbitrary (Fun x) = variant 1 . coarbitrary x
+
+instance Show b => Show (Fun a b) where
+ show (K x) = "K " ++ show x
+ show (Fun f) = "Fun " ++ show f
+
+instance (Show a, Arbitrary a, EqProp a, EqProp b) => EqProp (Fun a b) where
+ (=-=) = eqModels
+
+instance Model (Fun a b) (a -> b) where
+ model = apply
+
+instance Model1 (Fun a) ((->) a) where
+ model1 = apply
+
+-- | 'Fun' as a function
+apply :: Fun t a -> (t -> a)
+apply (K a) = const a
+apply (Fun f) = f
+
+instance Monoid a => Monoid (Fun t a) where
+ mempty = K mempty
+ K a `mappend` K a' = K (a `mappend` a')
+ funa `mappend` funb = Fun (apply funa `mappend` apply funb)
+
+instance Functor (Fun t) where
+ fmap f (K a) = K (f a)
+ fmap f (Fun g) = Fun (f.g)
+ -- Or use
+ -- fmap f = (pure f <*>)
+
+instance Applicative (Fun t) where
+ pure = K
+ K f <*> K x = K (f x)
+ cf <*> cx = Fun (apply cf <*> apply cx)
+
+instance Monad (Fun t) where
+ return = pure
+ K a >>= h = h a
+ Fun f >>= h = Fun (f >>= apply . h)
+
+#if __GLASGOW_HASKELL__ >= 609
+instance Category Fun where
+ id = Fun id
+ K b . _ = K b
+ Fun g . K a = K (g a)
+ Fun f . Fun g = Fun (f . g)
+#endif
+
+instance Arrow Fun where
+ arr = Fun
+#if __GLASGOW_HASKELL__ < 609
+ _ >>> K b = K b
+ K a >>> Fun g = K (g a)
+ Fun g >>> Fun f = Fun (g >>> f)
+#endif
+ first = Fun . first . apply
+ second = Fun . second . apply
+ K a' *** K b' = K (a',b')
+ f *** g = first f >>> second g
+
+batch :: TestBatch
+batch = ( "FRP.Reactive.Fun"
+ , concatMap unbatch
+ [ monoid (undefined :: Fun NumT
+ [T])
+ , semanticMonoid (undefined :: Fun NumT
+ [T])
+ , functor (undefined :: Fun NumT
+ (NumT
+ ,T
+ ,NumT))
+ , semanticFunctor (undefined :: Fun NumT ())
+ , applicative (undefined :: Fun NumT
+ (NumT
+ ,T
+ ,NumT))
+ , semanticApplicative (undefined :: Fun NumT ())
+ , monad (undefined :: Fun NumT
+ (NumT
+ ,T
+ ,NumT))
+ , semanticMonad (undefined :: Fun NumT ())
+ , arrow (undefined :: Fun NumT
+ (NumT
+ ,T
+ ,NumT))
+ , ("specifics",
+ [("Constants are"
+ ,property (\x -> (K (x :: NumT)) =-=
+ ((fun . const $ x) :: Fun T
+ NumT)))])
+ ]
+ )
diff --git a/src/FRP/Reactive/Future.hs b/src/FRP/Reactive/Future.hs
new file mode 100755
index 0000000..bcf38b0
--- /dev/null
+++ b/src/FRP/Reactive/Future.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Future
+-- Copyright : (c) Conal Elliott 2007-2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- A simple formulation of functional /futures/, roughly as
+-- described at <http://en.wikipedia.org/wiki/Futures_and_promises>.
+--
+-- A /future/ is a value with an associated time of /arrival/. Typically,
+-- neither the time nor the value can be known until the arrival time.
+--
+-- Primitive futures can be things like /the value of the next key you
+-- press/, or /the value of LambdaPix stock at noon next Monday/.
+--
+-- Composition is via standard type classes: 'Functor', 'Applicative',
+-- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of
+-- these classes:
+--
+-- * Monoid: 'mempty' is a future that never arrives (infinite time and
+-- undefined value), and @a `mappend` b@ is the earlier of @a@ and @b@,
+-- preferring @a@ when simultaneous.
+--
+-- * 'Functor': apply a function to a future argument. The (future)
+-- result arrives simultaneously with the argument.
+--
+-- * 'Applicative': 'pure' gives value arriving negative infinity.
+-- '(\<*\>)' applies a future function to a future argument, yielding a
+-- future result that arrives once /both/ function and argument have
+-- arrived (coinciding with the later of the two times).
+--
+-- * 'Monad': 'return' is the same as 'pure' (as usual). @(>>=)@ cascades
+-- futures. 'join' resolves a future future value into a future value.
+--
+-- Futures are parametric over /time/ as well as /value/ types. The time
+-- parameter can be any ordered type and is particularly useful with time
+-- types that have rich partial information structure, such as /improving
+-- values/.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Future
+ (
+ -- * Time & futures
+ Time, ftime
+ , FutureG(..), inFuture, inFuture2, futTime, futVal, future
+ , withTimeF
+ -- * Tests
+ , batch
+ ) where
+
+import Data.Monoid (Monoid(..))
+
+import Data.Max
+import Data.AddBounds
+import FRP.Reactive.Internal.Future
+
+-- Testing
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+{----------------------------------------------------------
+ Time and futures
+----------------------------------------------------------}
+
+-- | Make a finite time
+ftime :: t -> Time t
+ftime = Max . NoBound
+
+-- 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
+ Future a =-= Future b = a =-= b
+
+-- | A future's time
+futTime :: FutureG t a -> Time t
+futTime = fst . unFuture
+
+-- | A future's value
+futVal :: FutureG t a -> a
+futVal = snd . unFuture
+
+-- | A future value with given time & value
+future :: t -> a -> FutureG t a
+future t a = Future (ftime t, a)
+
+-- | Access time of future
+withTimeF :: FutureG t a -> FutureG t (Time t, a)
+withTimeF = inFuture $ \ (t,a) -> (t,(t,a))
+
+instance Ord 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) =
+ 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,_)) =
+-- if s <= t then fa else fb
+--
+-- Nothing can be known about the resulting future until @s <= t@ is
+-- determined. In particular, we cannot know lower bounds for the time.
+-- In contrast, the actual 'mappend' definition can potentially yield
+-- useful partial information, such as lower bounds, about the future
+-- time, if the type parameter @t@ has rich partial information structure
+-- (non-flat).
+
+-- For some choices of @t@, there may be an efficient combination of 'min'
+-- and '(<=)', so the 'mappend' definition is sub-optimal. In particular,
+-- 'Improving' has 'minI'.
+
+
+
+{----------------------------------------------------------
+ Tests
+----------------------------------------------------------}
+
+-- Represents times at a given instant.
+newtype TimeInfo t = TimeInfo (Maybe t)
+ deriving EqProp
+
+-- A time at a given instant can be some unknown time in the future
+unknownTimeInFuture :: TimeInfo a
+unknownTimeInFuture = TimeInfo Nothing
+
+-- or, a known time in the past. We're ignoring known future times for now.
+knownTimeInPast :: a -> TimeInfo a
+knownTimeInPast = TimeInfo . Just
+
+instance Eq a => Eq (TimeInfo a) where
+ TimeInfo Nothing == TimeInfo Nothing = error "Cannot tell if two unknown times in the future are equal"
+ TimeInfo (Just _) == TimeInfo Nothing = False
+ TimeInfo Nothing == TimeInfo (Just _) = False
+ TimeInfo (Just a) == TimeInfo (Just b) = a == b
+
+instance Ord a => Ord (TimeInfo a) where
+ -- The minimum of two unknown times in the future is an unkown time in the
+ -- future.
+ TimeInfo Nothing `min` TimeInfo Nothing = unknownTimeInFuture
+ TimeInfo Nothing `min` b = b
+ a `min` TimeInfo Nothing = a
+ TimeInfo (Just a) `min` TimeInfo (Just b) = (TimeInfo . Just) (a `min` b)
+
+ TimeInfo Nothing <= TimeInfo Nothing = error "Cannot tell if one unknown time in the future is less than another."
+ TimeInfo Nothing <= TimeInfo (Just _) = False
+ TimeInfo (Just _) <= TimeInfo Nothing = True
+ TimeInfo (Just a) <= TimeInfo (Just b) = a <= b
+
+batch :: TestBatch
+batch = ( "FRP.Reactive.Future"
+ , concatMap unbatch
+ [ monoid (undefined :: FutureG NumT T)
+ , functorMonoid (undefined :: FutureG NumT
+ (T,NumT))
+ -- Checking the semantics here isn't necessary because
+ -- the implementation is identical to them.
+ --
+ -- Also, Functor, Applicative, and Monad don't require checking
+ -- since they are automatically derived.
+ --
+ -- , semanticMonoid' (undefined :: FutureG NumT T)
+ -- , functor (undefined :: FutureG NumT (T,NumT,T))
+ -- , semanticFunctor (undefined :: FutureG NumT ())
+ -- , applicative (undefined :: FutureG NumT (NumT,T,NumT))
+ -- , semanticApplicative (undefined :: FutureG NumT ())
+ -- , monad (undefined :: FutureG NumT (NumT,T,NumT))
+ -- , semanticMonad (undefined :: FutureG NumT ())
+
+ , ("specifics",
+ [ ("laziness", property laziness )
+ ])
+ ]
+ )
+ where
+ laziness :: NumT -> 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")
diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs
new file mode 100755
index 0000000..1997d33
--- /dev/null
+++ b/src/FRP/Reactive/Improving.hs
@@ -0,0 +1,79 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Improving
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Improving values -- efficient version
+----------------------------------------------------------------------
+
+module FRP.Reactive.Improving
+ (
+ Improving(..), exactly, minI, maxI
+ ) where
+
+
+import Data.Function (on)
+
+import Data.Unamb (unamb,asAgree)
+import Test.QuickCheck.Checkers
+
+{----------------------------------------------------------
+ Improving values
+----------------------------------------------------------}
+
+-- | An improving value.
+data Improving a = Imp { exact :: a, compareI :: a -> Ordering }
+
+-- | A known improving value (which doesn't really improve)
+exactly :: Ord a => a -> Improving a
+exactly a = Imp a (compare a)
+
+instance Eq a => Eq (Improving a) where
+ (==) = (==) `on` exact
+
+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)
+ where
+ 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)
+ minComp = if uLeqV then uComp else 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.
+ wComp t = minComp t `unamb` (uComp t `asAgree` 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)
+ where
+ 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.
+ maxComp = if uGeqV then uComp else vComp
+ wComp t = maxComp t `unamb` (uComp t `asAgree` vComp t)
+
+-- TODO: factor commonality out of 'minI' and 'maxI' or combine into
+-- a single function.
+
+-- -- | Interpret 'Nothing' values as lower bounds
+-- improveMbs :: [(t, Maybe a)] -> [(Improving t, a)]
+-- ...
+
+-- No. Don't implement & export improveMbs. If it's being used, then
+-- we're not benefitting from this fancy multi-threaded implementation of
+-- Improving.
+
+instance (EqProp a) => EqProp (Improving a) where
+ (Imp a _) =-= (Imp b _) = a =-= b
diff --git a/src/FRP/Reactive/Internal/Behavior.hs b/src/FRP/Reactive/Internal/Behavior.hs
new file mode 100755
index 0000000..ae4cc77
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Behavior.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Behavior
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Representation of reactive behaviors
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Behavior (BehaviorG(..), beh, unb) where
+
+
+import Control.Applicative (Applicative)
+
+-- TypeCompose
+import Control.Compose ((:.)(..))
+
+import qualified FRP.Reactive.Reactive as R
+-- import FRP.Reactive.Reactive (TimeT)
+import FRP.Reactive.Fun
+
+
+-- Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in
+-- a type composition to get 'Functor' and 'Applicative' for free.
+
+-- | Reactive behaviors. They can be understood in terms of a simple
+-- model (denotational semantics) as functions of time, namely @at ::
+-- BehaviorG t a -> (t -> a)@.
+--
+-- The semantics of 'BehaviorG' instances are given by corresponding
+-- instances for the semantic model (functions). See
+-- <http://conal.net/blog/posts/simplifying-semantics-with-type-class-morphisms/>.
+--
+-- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at`
+-- t == f (r `at` t)@.
+--
+-- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s
+-- \<*\> at t@. That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t
+-- == (s `at` t) (r `at` t)@.
+--
+-- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at
+-- . at rr)@. That is, @return a `at` t == a@, and @join rr `at` t ==
+-- (rr `at` t) `at` t@. As always, @(r >>= f) == join (fmap f r)@.
+-- @at (r >>= f) == at r >>= at . f@.
+--
+-- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then
+-- @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend
+-- == liftA2 mappend@. That is, @mempty `at` t == mempty@, and @(r
+-- `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@
+newtype BehaviorG tr tf a = Beh { unBeh :: (R.ReactiveG tr :. Fun tf) a }
+ deriving (Functor,Applicative)
+
+-- | Wrap a reactive time fun as a behavior.
+beh :: R.ReactiveG tr (Fun tf a) -> BehaviorG tr tf a
+beh = Beh . O
+
+-- | Unwrap a behavior.
+unb :: BehaviorG tr tf a -> R.ReactiveG tr (Fun tf a)
+unb = unO . unBeh
diff --git a/src/FRP/Reactive/Internal/Clock.hs b/src/FRP/Reactive/Internal/Clock.hs
new file mode 100755
index 0000000..2ebb3d3
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Clock.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Clock
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Serializing clocks
+--
+-- Thanks to Luke Palmer for help with this module.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Clock
+ (Clock(..), makeClock) where
+
+import Control.Applicative (liftA2)
+import System.Time
+
+import FRP.Reactive.Reactive (TimeT)
+-- import FRP.Reactive.Internal.Misc (Sink)
+import FRP.Reactive.Internal.Serial
+
+
+-- | Waits a specified duration and then execute an action
+-- type Delay t = t -> forall a. IO a -> IO a
+
+-- | Waits until just after a specified time and then execute an action,
+-- passing in the actual time.
+-- type Schedule t = t -> Sink (Sink t)
+
+-- | A serializing clock. Can (a) produce a time and (b) serialize an
+-- action.
+data Clock t = Clock { cGetTime :: IO t
+ , cSerialize :: Serial
+ }
+
+-- | Make a clock, given a way to delay actions. For instance, the delay
+-- could be 'sleepThen' in thread-safe situations, but could also
+-- involve a GUI toolkit wake-up event.
+makeClock :: IO (Clock TimeT)
+makeClock = liftA2 clock getClockTime makeSerial
+ where
+ clock :: ClockTime -> Serial -> Clock TimeT
+ clock refTime serial =
+ Clock (currRelTime refTime) serial
+
+
+-- TODO: How can i know that actions are carried out monotonically?
+
+-- | Get the current time in seconds, relative to a start 'ClockTime'.
+currRelTime :: ClockTime -> IO TimeT
+currRelTime (TOD sec0 pico0) = fmap delta getClockTime
+ where
+ delta (TOD sec pico) =
+ fromIntegral (sec-sec0) + 1.0e-12 * fromIntegral (pico-pico0)
diff --git a/src/FRP/Reactive/Internal/Fun.hs b/src/FRP/Reactive/Internal/Fun.hs
new file mode 100755
index 0000000..f4ed08e
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Fun.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Fun
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Constant-optimized representation of functions.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Fun (Fun(..)) where
+
+-- | Constant-optimized functions
+data Fun t a = K a -- ^ constant function
+ | Fun (t -> a) -- ^ non-constant function
diff --git a/src/FRP/Reactive/Internal/Future.hs b/src/FRP/Reactive/Internal/Future.hs
new file mode 100755
index 0000000..e64ecb9
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Future.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Future
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Representation of future values
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Future
+ (
+ -- * Time & futures
+ Time
+ , FutureG(..), inFuture, inFuture2
+ , runF
+ ) where
+
+
+import Control.Applicative (Applicative(..))
+
+import Test.QuickCheck
+
+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)
+
+
+-- | 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, Show, Arbitrary)
+
+-- 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'.
+
+
+-- | Apply a unary function within the 'FutureG' representation.
+inFuture :: ((Time t, a) -> (Time t', b))
+ -> FutureG t a -> FutureG t' b
+inFuture f = Future . f . unFuture
+
+-- | Apply a binary function within the 'FutureG' representation.
+inFuture2 :: ((Time t, a) -> (Time t', b) -> (Time t', c))
+ -> FutureG t a -> FutureG t' b -> FutureG t' c
+inFuture2 f = inFuture . f . unFuture
+
+
+-- | 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"
+
diff --git a/src/FRP/Reactive/Internal/IVar.hs b/src/FRP/Reactive/Internal/IVar.hs
new file mode 100755
index 0000000..48204b4
--- /dev/null
+++ b/src/FRP/Reactive/Internal/IVar.hs
@@ -0,0 +1,44 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.IVar
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Write-once variables.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.IVar
+ ( IVar, newEmptyIVar, readIVar, tryReadIVar, writeIVar )
+where
+
+import Control.Concurrent.MVar
+import Control.Applicative ((<$>))
+import System.IO.Unsafe (unsafePerformIO)
+
+newtype IVar a = IVar (MVar a)
+
+newEmptyIVar :: IO (IVar a)
+newEmptyIVar = IVar <$> newEmptyMVar
+
+-- | 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
+
+-- | Returns Nothing if the IVar has no value yet, otherwise
+-- returns the value.
+tryReadIVar :: IVar a -> IO (Maybe a)
+tryReadIVar (IVar v) = do
+ empty <- isEmptyMVar v
+ if empty
+ then return Nothing
+ else Just <$> readMVar v
+
+-- | Puts the value of the IVar. If it already has a value,
+-- block forever.
+writeIVar :: IVar a -> a -> IO ()
+writeIVar (IVar v) x = putMVar v x
diff --git a/src/FRP/Reactive/Internal/Misc.hs b/src/FRP/Reactive/Internal/Misc.hs
new file mode 100755
index 0000000..6e650fa
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Misc.hs
@@ -0,0 +1,23 @@
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Misc
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Misc Reactive internal defs
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Misc
+ (
+ Action, Sink
+ ) where
+
+
+-- | Convenient alias for dropping parentheses.
+type Action = IO ()
+
+-- | Value consumer
+type Sink a = a -> Action
diff --git a/src/FRP/Reactive/Internal/Reactive.hs b/src/FRP/Reactive/Internal/Reactive.hs
new file mode 100755
index 0000000..43a74ac
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Reactive.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS -Wall #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Reactive
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Representation for 'Reactive' and 'Event' types. Combined here,
+-- because they're mutually recursive.
+--
+-- The representation used in this module is based on a close connection
+-- between these two types. A reactive value is defined by an initial
+-- value and an event that yields future values; while an event is given
+-- as a future reactive value.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Reactive
+ (
+ EventG(..), inEvent, inEvent2, eFutures
+ , ReactiveG(..), inREvent, inFutR
+ , runE, runR, forkE, forkR
+ ) where
+
+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
+
+-- | Events. Semantically: time-ordered list of future values.
+-- Instances:
+--
+-- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend`
+-- e'@ is the event that combines occurrences from @e@ and @e'@.
+--
+-- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs,
+-- and whose occurrence values come from applying @f@ to the values from
+-- @e@.
+--
+-- * 'Applicative': @pure a@ is an event with a single occurrence at time
+-- -Infinity. @ef \<*\> ex@ is an event whose occurrences are made from
+-- the /product/ of the occurrences of @ef@ and @ex@. For every occurrence
+-- @f@ at time @tf@ of @ef@ and occurrence @x@ at time @tx@ of @ex@, @ef
+-- \<*\> ex@ has an occurrence @f x@ at time @tf `max` tx@. N.B.: I
+-- don't expect this instance to be very useful. If @ef@ has @nf@
+-- instances and @ex@ has @nx@ instances, then @ef \<*\> ex@ has @nf*nx@
+-- instances. However, there are only @nf+nx@ possibilities for @tf
+-- `max` tx@, so many of the occurrences are simultaneous. If you think
+-- you want to use this instance, consider using 'Reactive' instead.
+--
+-- * 'Monad': @return a@ is the same as @pure a@ (as usual). In @e >>= f@,
+-- each occurrence of @e@ leads, through @f@, to a new event. Similarly
+-- for @join ee@, which is somehow simpler for me to think about. The
+-- occurrences of @e >>= f@ (or @join ee@) correspond to the union of the
+-- occurrences (temporal interleaving) of all such events. For example,
+-- suppose we're playing Asteroids and tracking collisions. Each collision
+-- can break an asteroid into more of them, each of which has to be tracked
+-- for more collisions. Another example: A chat room has an /enter/ event,
+-- whose occurrences contain new events like /speak/. An especially useful
+-- monad-based function is 'joinMaybes', which filters a Maybe-valued
+-- event.
+
+newtype EventG t a = Event { eFuture :: FutureG t (ReactiveG t a) }
+
+-- The event representation requires temporal monotonicity but does not
+-- enforce it, which invites bugs. Every operation therefore must be
+-- tested for preserving monotonicity. (Better yet, find an efficient
+-- representation that either enforces or doesn't require monotonicity.)
+
+-- Why the newtype for 'EventG?' Because the 'Monoid' instance of 'Future'
+-- does not do what I want for 'EventG'. It will pick just the
+-- earlier-occurring event, while I want an interleaving of occurrences
+-- from each. Similarly for other classes.
+
+
+-- TODO: Alternative and MonadPlus instances for EventG
+
+-- | Reactive value: a discretely changing value. Reactive values can be
+-- understood in terms of (a) a simple denotational semantics of reactive
+-- values as functions of time, and (b) the corresponding instances for
+-- functions. The semantics is given by the function @at :: ReactiveG t a ->
+-- (t -> a)@. A reactive value may also be thought of (and in this module
+-- is implemented as) a current value and an event (stream of future values).
+--
+-- The semantics of 'ReactiveG' instances are given by corresponding
+-- instances for the semantic model (functions):
+--
+-- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at`
+-- t == f (r `at` t)@.
+--
+-- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s
+-- \<*\> at t@. That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t
+-- == (s `at` t) (r `at` t)@.
+--
+-- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at
+-- . at rr)@. That is, @return a `at` t == a@, and @join rr `at` t ==
+-- (rr `at` t) `at` t@. As always, @(r >>= f) == join (fmap f r)@.
+-- @at (r >>= f) == at r >>= at . f@.
+--
+-- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then
+-- @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend
+-- == liftA2 mappend@. That is, @mempty `at` t == mempty@, and @(r
+-- `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@
+
+data ReactiveG t a = a `Stepper` EventG t a
+
+
+{--------------------------------------------------------------------
+ Applying functions inside of representations
+--------------------------------------------------------------------}
+
+-- | Apply a unary function inside an 'EventG' representation.
+inEvent :: (FutureG s (ReactiveG s a) -> FutureG t (ReactiveG t b))
+ -> (EventG s a -> EventG t b)
+inEvent f = Event . f . eFuture
+
+-- | Apply a unary function inside an 'EventG' representation.
+inEvent2 :: (FutureG t (ReactiveG t a) -> FutureG t (ReactiveG t b)
+ -> FutureG t (ReactiveG t c))
+ -> (EventG t a -> EventG t b -> EventG t c)
+inEvent2 f = inEvent . f . eFuture
+
+-- | Apply a unary function inside the 'rEvent' part of a 'Reactive'
+-- representation.
+inREvent :: (EventG s a -> EventG t a)
+ -> (ReactiveG s a -> ReactiveG t a)
+inREvent f (a `Stepper` e) = a `Stepper` f e
+
+-- | Apply a unary function inside the future reactive inside a 'Reactive'
+-- representation.
+inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b))
+ -> (ReactiveG s b -> ReactiveG t b)
+inFutR = inREvent . inEvent
+
+
+{--------------------------------------------------------------------
+ Showing values (exposing rep)
+--------------------------------------------------------------------}
+
+-- | Make the event into a list of futures
+eFutures :: EventG t a -> [FutureG t a]
+eFutures (Event (Future (Max MaxBound,_))) = []
+eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e
+
+-- TODO: redefine 'eFutures' as an unfold
+
+
+-- 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 ++ ")"
+
+-- 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) ++ "..."
+
+-- 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 (Show x, Show y) => Show (ReactiveG x y) where
+ show (x `Stepper` e) = show x ++ " `Stepper` " ++ show e
+
+
+{--------------------------------------------------------------------
+ Execution
+--------------------------------------------------------------------}
+
+-- | 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!
+
+-- TODO: I'm not sure about the MaxBound case. We could instead just wait
+-- forever (cheaply). Try out this terminating definition instead.
+
+-- | 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 = (fmap.fmap) forkIO runE
+
+-- TODO: Revisit this tsync definition. For instance, maybe the MaxBound
+-- case ought to simply return.
+
+-- | 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 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 = (fmap.fmap) forkIO runR
diff --git a/src/FRP/Reactive/Internal/Serial.hs b/src/FRP/Reactive/Internal/Serial.hs
new file mode 100755
index 0000000..22d5a14
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Serial.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE Rank2Types, ImpredicativeTypes #-}
+-- We need ImpredicativeTypes, but GHC 6.8 doesn't think it
+-- has them. The cabal file configures this in a compiler-dependent
+-- way.
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Serial
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Serialize actions.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Serial
+ ( Serial, makeSerial, locking
+ ) where
+
+import Control.Concurrent.MVar
+import Control.Applicative((<$>))
+import Control.Exception (bracket_)
+
+-- | Serializer. Turns actions into equivalent but serialized actions
+type Serial = forall a. IO a -> IO a
+
+-- | Make a locking serializer
+makeSerial :: IO Serial
+makeSerial = locking <$> newEmptyMVar
+
+-- | Make a locking serializer with a given lock
+locking :: MVar () -> Serial
+locking lock = bracket_ (putMVar lock ()) (takeMVar lock)
diff --git a/src/FRP/Reactive/Internal/TVal.hs b/src/FRP/Reactive/Internal/TVal.hs
new file mode 100755
index 0000000..524da93
--- /dev/null
+++ b/src/FRP/Reactive/Internal/TVal.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.TVal
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Timed values. A primitive interface for futures.
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.TVal
+ (
+ makeFuture, makeEvent, Fed, MkFed
+ ) where
+
+
+import Control.Arrow (first)
+import Control.Applicative ((<$>))
+import Control.Monad (forever)
+import Control.Concurrent (forkIO,yield)
+import Control.Concurrent.Chan
+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.PrimReactive (futuresE)
+
+import FRP.Reactive.Internal.Misc (Sink)
+import FRP.Reactive.Internal.Clock
+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
+-- 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.
+
+-- | 'TVal' as 'Future'
+tValFuture :: Ord t => TVal t a -> FutureG (Improving t) a
+tValFuture v = future (tValImp v) (snd (timeVal v))
+
+-- | 'TVal' as 'Improving'
+tValImp :: Ord t => TVal t a -> Improving t
+tValImp v = Imp ta (\ t -> assuming (not (definedAt v t)) GT
+ `unamb` (ta `compare` t))
+ where
+ ta = fst (timeVal v)
+
+-- | An @a@ that's fed by a @b@
+type Fed a b = (a, Sink b)
+
+-- | Make a 'Fed'.
+type MkFed a b = IO (Fed a b)
+
+-- | 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
+
+-- | 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 = (fmap.first) futuresE (listSink (makeFuture clock))
+
+listSink :: MkFed a b -> MkFed [a] b
+listSink mk = do chanA <- newChan
+ chanB <- newChan
+ forkIO . forever $ 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
diff --git a/src/FRP/Reactive/Internal/Timing.hs b/src/FRP/Reactive/Internal/Timing.hs
new file mode 100755
index 0000000..ffb7646
--- /dev/null
+++ b/src/FRP/Reactive/Internal/Timing.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Internal.Timing
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+--
+----------------------------------------------------------------------
+
+module FRP.Reactive.Internal.Timing (mkUpdater,sleepPast) where
+
+import Data.Monoid (mempty)
+import Control.Applicative ((<$>))
+import Control.Monad (unless)
+import Data.IORef
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.SampleVar
+
+-- For IO monoid
+import Control.Instances ()
+
+import FRP.Reactive.Reactive (TimeT)
+import FRP.Reactive.Improving (Improving,exact)
+import FRP.Reactive.Behavior (Behavior)
+
+import FRP.Reactive.Internal.Misc (Action,Sink)
+import FRP.Reactive.Internal.Reactive (forkR)
+import FRP.Reactive.Internal.Behavior (unb)
+import FRP.Reactive.Internal.Fun
+
+-- | If a sample variable is full, act on the contents, leaving it empty.
+drainS :: SampleVar a -> Sink (Sink a)
+drainS sv snk = do emptySVar <- isEmptySampleVar sv
+ unless emptySVar (readSampleVar sv >>= snk)
+
+-- TODO: Generalize from TimeT below, using BehaviorG.
+
+noSink :: Sink t
+noSink = mempty -- const (putStrLn "noSink")
+
+-- | Make an action to be executed regularly, given a time-source and a
+-- action-behavior. The generated action is optimized to do almost no
+-- work during known-constant phases of the given behavior.
+mkUpdater :: IO TimeT -> Behavior Action -> IO Action
+mkUpdater getT acts =
+ -- 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)
+ (writeSampleVar' actSVar <$> unb acts)
+ tfunRef <- newIORef (noSink :: Sink TimeT)
+ return $
+ do -- When there's a new time fun, execute it once if
+ -- constant, or remember for repeated execution if
+ -- non-constant.
+ now <- getT
+ -- putStrLn ("scheduler: time == " ++ show now)
+ drainS actSVar $ \ actF ->
+ case actF of
+ K c -> do -- putStrLn "K"
+ writeIORef tfunRef noSink >> c
+ Fun f -> do -- putStrLn "Fun"
+ writeIORef tfunRef f
+ readIORef tfunRef >>= ($ now)
+ -- yield -- experiment
+ where
+ writeSampleVar' v x = do -- putStrLn "writeSampleVar"
+ writeSampleVar v x
+
+-- | Pause a thread for the given duration in seconds
+sleep :: Sink TimeT
+sleep = threadDelay . ceiling . (1.0e6 *)
+
+-- | Sleep past a given time
+sleepPast :: IO TimeT -> Sink TimeT
+sleepPast getT !target = loop
+ where
+ -- 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
diff --git a/src/FRP/Reactive/LegacyAdapters.hs b/src/FRP/Reactive/LegacyAdapters.hs
new file mode 100755
index 0000000..d8955c1
--- /dev/null
+++ b/src/FRP/Reactive/LegacyAdapters.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE Rank2Types #-}
+{-# OPTIONS_GHC -Wall #-}
+module FRP.Reactive.LegacyAdapters
+ ( BehaviorMachine(..)
+ , makeBehaviorMachine
+ , makeEvent, Sink
+ -- * Deprecated and/or for testing.
+ , forkE
+ , forkB
+ ) where
+
+import Control.Compose ((:.)(O))
+import Control.Concurrent(ThreadId)
+
+import System.Time
+
+import FRP.Reactive.Improving
+import FRP.Reactive.Future
+import FRP.Reactive.Fun
+import FRP.Reactive.Reactive
+import Data.Max
+import Data.AddBounds
+
+import qualified FRP.Reactive.Internal.Reactive as R
+import FRP.Reactive.Internal.Misc (Sink)
+import FRP.Reactive.Behavior (Behavior)
+import FRP.Reactive.Internal.Behavior (BehaviorG(..))
+
+import qualified FRP.Reactive.Internal.TVal as TVal
+import FRP.Reactive.Internal.Clock
+
+
+data BehaviorMachine a
+ = BehaviorMachine { currentValue :: a
+ , currentTime :: TimeT
+ , waitChange :: IO (BehaviorMachine a)
+ }
+
+makeBehaviorMachine :: ClockTime -> Behavior a -> IO (BehaviorMachine a)
+makeBehaviorMachine refTime (Beh (O (R.Stepper initval ev))) = do
+ clock <- makeClock refTime
+ curTime <- currRelTime refTime
+ return $ eventBehaviorMachine refTime clock initval curTime ev
+
+eventBehaviorMachine :: ClockTime -> Clock TimeT
+ -> Fun TimeT a -> TimeT -> Event (Fun TimeT a) -> BehaviorMachine a
+eventBehaviorMachine refTime clock = go
+ where
+ go initVal initTime event =
+ BehaviorMachine { currentValue = apply initVal initTime
+ , currentTime = initTime
+ , waitChange = do
+ let fut = eventOcc event
+ schedule clock (fromTime (futTime fut))
+ let (v,nexte) = futVal fut
+ curTime <- currRelTime refTime
+ return $ go v curTime nexte
+ }
+
+fromTime :: Num a => Max (AddBounds (Improving a)) -> a
+fromTime (Max MinBound) = 0
+fromTime (Max (NoBound t)) = exact t
+fromTime (Max MaxBound) = error "maxbound"
+
+
+makeEvent :: ClockTime -> IO (Event a, Sink a)
+makeEvent refTime = TVal.makeEvent =<< makeClock refTime
+
+-- | Forks a behavior given a reference time and a time function sinker. This
+-- function is deprecated, but will remain until something better, and working,
+-- comes along.
+forkB :: ClockTime -> -- The reference time
+ Behavior a -> -- The behavior
+ Sink (Fun TimeT a) -> -- An action that takes in a Fun of time to a
+ IO ThreadId
+forkB refTime (Beh (O r)) fSync = do
+ clock <- makeClock refTime
+ R.forkR (schedule clock . exact) (fmap fSync r)
+
+-- | A version of forkE that acts more like makeEvent and uses Clock as a
+-- basis. Takes reference time and the event to fork.
+forkE :: ClockTime ->
+ Event (IO a) ->
+ IO ThreadId
+forkE refTime e = do
+ clock <- makeClock refTime
+ R.forkE (schedule clock . exact) e
diff --git a/src/FRP/Reactive/Num.hs b/src/FRP/Reactive/Num.hs
new file mode 100755
index 0000000..85beab3
--- /dev/null
+++ b/src/FRP/Reactive/Num.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+
+module FRP.Reactive.Num () where
+
+import FRP.Reactive.Behavior
+import Control.Applicative
+
+noOv :: String -> String -> a
+noOv ty meth = error $ meth ++ ": No overloading for " ++ ty
+
+noFun :: String -> a
+noFun = noOv "function"
+
+-- Eq & Show are prerequisites for Num, so they need to be faked here
+instance Eq (Behavior b) where
+ (==) = noFun "(==)"
+ (/=) = noFun "(/=)"
+
+instance Ord b => Ord (Behavior b) where
+ min = liftA2 min
+ max = liftA2 max
+
+instance Show (Behavior b) where
+ show = noFun "show"
+ showsPrec = noFun "showsPrec"
+ showList = noFun "showList"
+
+instance Num b => Num (Behavior b) where
+ negate = fmap negate
+ (+) = liftA2 (+)
+ (*) = liftA2 (*)
+ fromInteger = pure . fromInteger
+ abs = fmap abs
+ signum = fmap signum
+
+instance Fractional b => Fractional (Behavior b) where
+ recip = fmap recip
+ fromRational = pure . fromRational
+
+instance Floating b => Floating (Behavior b) where
+ pi = pure pi
+ sqrt = fmap sqrt
+ exp = fmap exp
+ log = fmap log
+ sin = fmap sin
+ cos = fmap cos
+ asin = fmap asin
+ atan = fmap atan
+ acos = fmap acos
+ sinh = fmap sinh
+ cosh = fmap cosh
+ asinh = fmap asinh
+ atanh = fmap atanh
+ acosh = fmap acosh
+
diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs
new file mode 100755
index 0000000..f09b7d7
--- /dev/null
+++ b/src/FRP/Reactive/PrimReactive.hs
@@ -0,0 +1,759 @@
+{-# LANGUAGE TypeOperators, ScopedTypeVariables
+ , FlexibleInstances, MultiParamTypeClasses
+ , GeneralizedNewtypeDeriving
+ #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+
+-- For ghc-6.6 compatibility
+-- {-# OPTIONS_GHC -fglasgow-exts -Wall #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.PrimReactive
+-- Copyright : (c) Conal Elliott 2007
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Functional /events/ and /reactive values/. Semantically, an 'Event' is
+-- stream of future values in time order. A 'Reactive' value is a
+-- discretly time-varying value.
+--
+-- Many of the operations on events and reactive values are packaged as
+-- instances of the standard type classes 'Monoid', 'Functor',
+-- 'Applicative', and 'Monad'.
+--
+-- This module focuses on representation and primitives defined in terms
+-- of the representation. See also "FRP.Reactive.Reactive", which
+-- re-exports this module, plus extras that do not exploit the
+-- representation. My intention for this separation is to ease
+-- experimentation with alternative representations.
+--
+-- Although the basic 'Reactive' type describes /discretely/-changing
+-- values, /continuously/-changing values can be modeled simply as
+-- reactive functions. See "FRP.Reactive.Behavior" for a convenient type
+-- composition of 'Reactive' and a constant-optimized representation of
+-- functions of time. The exact packaging of discrete vs continuous will
+-- probably change with more experience.
+----------------------------------------------------------------------
+
+module FRP.Reactive.PrimReactive
+ ( -- * Events and reactive values
+ EventG, ReactiveG
+ -- * Operations on events and reactive values
+ , stepper, switcher, withTimeGE, withTimeGR
+ , futuresE, listEG, atTimesG, atTimeG
+ , snapshotWith, accumE, accumR, once
+ , firstRestE, firstE, restE
+ , remainderR, withRestE, untilE
+ -- , traceE, traceR
+ -- , mkEvent, mkEventTrace, mkEventShow
+ , eventOcc
+ -- * To be moved elsewhere
+ , joinMaybes, filterMP
+ -- * To be removed when it gets used somewhere
+ , isMonotoneR
+ -- * Testing
+ , batch, infE
+ ) where
+
+import Data.Monoid
+import Control.Applicative
+import Control.Monad
+import Data.Function (on)
+
+-- TODO: eliminate the needs for this stuff.
+import Control.Concurrent (threadDelay)
+import Control.Exception (evaluate)
+import System.IO.Unsafe
+
+import Test.QuickCheck hiding (evaluate)
+import Test.QuickCheck.Instances
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+-- import Data.List
+
+-- TypeCompose
+import Control.Compose ((:.)(..), inO2, Monoid_f(..))
+import Data.Pair
+import Control.Instances () -- Monoid (IO ())
+
+import Data.Unamb (race)
+
+import Data.Max
+import Data.AddBounds
+import FRP.Reactive.Future hiding (batch)
+import FRP.Reactive.Internal.Reactive
+
+{--------------------------------------------------------------------
+ Events and reactive values
+--------------------------------------------------------------------}
+
+-- 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
+ 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)
+arbitraryE = frequency
+ [ (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)]
+ futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary
+ futureListInf =
+ liftA2 (zipWith future) (resize 10 nondecreasingInf)
+ (infiniteList arbitrary)
+
+instance (Arbitrary t, Ord t, Num t, Arbitrary a) => Arbitrary (EventG t a) where
+ arbitrary = arbitraryE
+ -- TODO: Fix this coarbitrary instance -- David
+ coarbitrary = error "coarbitrary Events not supported"
+ -- coarbitrary = coarbitrary . eFuture
+
+----
+
+-- Arbitrary works just like pairs:
+instance (Arbitrary t, Arbitrary a, Num t, Ord 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
+ model = rat
+
+instance (Ord t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)
+ where
+ (=-=) = (=-=) `on` model
+
+-- Initial value of a 'Reactive'
+rInit :: ReactiveG t a -> a
+rInit (a `Stepper` _) = a
+
+
+{--------------------------------------------------------------------
+ Instances
+--------------------------------------------------------------------}
+
+instance Ord 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
+ mempty = pure mempty
+ mappend = liftA2 mappend
+
+-- | 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.
+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,
+-- begin as v begins and then merge u with the rest of v. Because of
+-- the left-bias, make sure u fragments are always the first argument
+-- to merge and v fragments are always the second.
+
+
+-- Define functor instances in terms of each other.
+instance Functor (EventG t) where
+ fmap f = inEvent $ (fmap.fmap) f
+
+instance Functor (ReactiveG t) where
+ fmap f (a `Stepper` e) = f a `stepper` fmap f e
+
+-- standard instance
+instance Ord t => Applicative (EventG t) where
+ pure = return
+ _ <*> (Event (Future (Max MaxBound,_))) = mempty
+ x <*> y = x `ap` y
+
+-- standard instance
+instance Ord t => Alternative (EventG t) where
+ { empty = mempty; (<|>) = mappend }
+
+instance Ord t => Pair (ReactiveG t) where
+ -- pair :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b)
+ (c `Stepper` ce) `pair` (d `Stepper` de) =
+ (c,d) `accumR` pairEdit (ce,de)
+
+instance Ord t => Applicative (ReactiveG t) where
+ pure a = a `stepper` mempty
+ -- Standard definition. See 'Pair'.
+ rf <*> rx = uncurry ($) <$> (rf `pair` rx)
+
+-- A wonderful thing about the <*> definition for ReactiveG is that it
+-- automatically caches the previous value of the function or argument
+-- when the argument or function changes.
+
+
+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.
+happy :: (Ord t) => EventG t a ->
+ Time t ->
+ EventG t a ->
+ EventG t a
+happy a (Max MaxBound) _ = a
+happy (Event (Future (Max MaxBound, _))) _ b = b
+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
+joinE (Event (Future (Max MaxBound, _))) = mempty
+joinE (Event (Future (t0h, e `Stepper` ((Event (Future (Max MaxBound, _)))))))
+ = adjustE t0h e
+joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _)))))))
+ = happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee'))
+
+-- 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 (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
+
+-- TODO: add adjustE explanation. What's going on and why t1 in the
+-- recursive call? David's comment:
+-- If we have an event [t1, t2] we know t2 >= t1 so (max t t2) == (max (max t t1) t2).
+-- See http://hpaste.org/11518 for a def that doesn't change the lower bound.
+--
+-- What I remember is that this function is quite subtle w.r.t laziness.
+-- There are some notes in the paper. If i find instead that a simpler
+-- definition is possible, so much the better.
+
+-- Here's an alternative to joinE that is less strict, and doesn't cause
+-- 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 (Event (Future (t0h, ~(e `Stepper` ee')))) =
+ adjustE t0h (e `mappend` joinE ee')
+
+adjustE t0h (Event (Future (tah, ~(a `Stepper` e)))) =
+ Event (Future (t1h,a `Stepper` adjustE t1h e))
+ where
+ t1h = t0h `max` tah
+-}
+
+instance Ord t => MonadPlus (EventG t) where { mzero = mempty; mplus = mappend }
+
+-- Standard instance for Applicative w/ join
+instance Ord t => Monad (ReactiveG t) where
+ return = pure
+ r >>= f = joinR (f <$> r)
+
+
+{--------------------------------------------------------------------
+ Operations on events and reactive values
+--------------------------------------------------------------------}
+
+-- | Reactive value from an initial value and a new-value event.
+stepper :: a -> EventG t a -> ReactiveG t a
+stepper = Stepper
+
+-- -- | Turn a reactive value into an event, with the initial value
+-- -- occurring at -Infinity.
+-- --
+-- -- Oops: breaks the semantic abstraction of 'Reactive' as a step
+-- function.
+-- rToE :: Ord 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
+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 ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u
+ where
+ u = ((`switcher` e') <$> ur) `mappend` (join <$> urr)
+
+-- The following simpler definition is wrong. It keeps listening to @e@
+-- even after @er@ has occurred.
+-- joinR ((a `Stepper` e) `Stepper` er) =
+-- a `stepper` (e `mappend` join (rToE <$> er))
+
+-- e :: EventG t a
+-- er :: EventG t (ReactiveG t a)
+--
+-- rToE <$> er ::: EventG t (EventG t a)
+-- join (rToE <$> er) ::: EventG t a
+
+-- | Access occurrence times in an event. See also 'withTimeGR'.
+withTimeGE :: EventG t a -> EventG t (a, Time t)
+withTimeGE = inEvent $ inFuture $ \ (t,r) -> (t, withTimeGR t r)
+
+-- | Access occurrence times in a reactive value. See also 'withTimeGE'.
+withTimeGR :: Time t -> ReactiveG t a -> ReactiveG t (a, Time t)
+withTimeGR t (a `Stepper` e) = (a,t) `Stepper` withTimeGE e
+
+-- | Convert a temporally monotonic list of futures to an event. See also
+-- the specialization 'listE'
+listEG :: Ord 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 [] = mempty
+futuresE (Future (t,a) : futs) =
+ -- trace ("l2E: "++show t) $
+ Event (Future (t, a `stepper` futuresE futs))
+
+-- TODO: redefine 'futuresE' as a fold
+-- futuresE = foldr (\ fut e -> Event ((`stepper` e) <$> fut)) mempty
+
+-- TODO: hide futuresE. currently exported for use in TVal. If I move to
+-- Internal/Reactive, I have to move the monoid instance there, which
+-- requires moving others as well.
+
+-- | Event at given times. See also 'atTimeG'.
+atTimesG :: Ord t => [t] -> EventG t ()
+atTimesG = listEG . fmap (flip (,) ())
+
+-- | Single-occurrence event at given time.
+atTimeG :: Ord t => t -> EventG t ()
+atTimeG t = futuresE (pure (future t ()))
+
+-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
+-- didn't.
+snap :: forall a b t. Ord t =>
+ EventG t a -> ReactiveG t b -> EventG t (Maybe a, b)
+ea `snap` (b0 `Stepper` eb) =
+ (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)
+
+-- | 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 f e r = joinMaybes $ fmap h (e `snap` r)
+ where
+ h (Nothing,_) = Nothing
+ h (Just a ,b) = Just (f a b)
+
+-- | Accumulating event, starting from an initial value and a
+-- update-function event. See also 'accumR'.
+-- Example: (using a list rempresentation for events, for clarity
+-- @10 `accumE`
+-- [(5 seconds, (+2)),(10 seconds, (subtract 30)),(20 seconds,(*10))]
+-- = [(5 seconds, 12),(10 seconds, -18),(20 seconds, -180)]@
+-- If you want an initial occurance at @-infinity@ you can use @pure a
+-- `mappend` accumE a e@
+accumE :: a -> EventG t (a -> a) -> EventG t a
+accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'
+
+-- | Reactive value from an initial value and an updater event. See also
+-- 'accumE'.
+accumR :: a -> EventG t (a -> a) -> ReactiveG t a
+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
+
+-- | 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 (Event fut) = f (futVal fut)
+ where
+ f (a `Stepper` b) = (a,b)
+
+-- | Extract the first occurrence value of an event. See also
+-- 'firstRestE' and 'restE'.
+firstE :: Ord 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 = snd . firstRestE
+
+
+-- | Remaining part of an event. See also 'withRestE'.
+remainderR :: Ord t => EventG t a -> ReactiveG t (EventG t a)
+remainderR e = e `stepper` (snd <$> withRestE e)
+
+-- -- | Event remainders. Replace event values with a reactive that starts
+-- -- with that value and follows the event. Sort of like 'tails'.
+-- eventR :: Ord t => EventG t a -> EventG t (ReactiveG t a)
+-- eventR = inEvent $ fmap $ \ r@(_ `Stepper` e') -> r `Stepper` eventR e'
+
+-- Also try the following definition of remainderR
+
+-- remainderR :: forall t a. Ord t => EventG t a -> ReactiveG t (EventG t a)
+-- remainderR e = e `accumR` (next <$ e)
+-- where
+-- next :: Unop (EventG t a)
+-- next ~(Event (Future (_, _ `Stepper` e'))) = e'
+
+-- newtype EventG t a = Event { eFuture :: FutureG t (ReactiveG t a) }
+
+-- | Access the remainder with each event occurrence.
+withRestE :: EventG t a -> EventG t (a, EventG t a)
+withRestE = inEvent $ fmap $
+ \ (a `Stepper` e') -> (a,e') `stepper` withRestE e'
+
+
+-- | Truncate first event at first occurrence of second event.
+untilE :: Ord 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
+
+-- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t =
+-- if ta < t then
+-- Event (Future (ta, a `Stepper` (e' `untilET` t)))
+-- else
+-- mempty
+
+-- Hm. I doubt that the definition above gives sufficient temporal
+-- laziness. No information can come out of the result until the value of
+-- @ta < t@ is determined, which is usually at about time @ta `min` t@.
+
+-- So, try the following definition instead. It immediately provides
+-- lower bounds of both @ta@ and @t@ as lower bounds of the constructed
+-- event occurrences.
+
+Event (Future ~(ta, a `Stepper` e')) `untilET` t =
+ Event (Future (ta', a `Stepper` (e' `untilET` t)))
+ where
+ ta' = (ta `min` t) `max` (if ta < t then ta else maxBound)
+
+-- I'm not sure about @<@ vs @<=@ above.
+
+{-
+-- | Tracing of events.
+traceE :: Show t => (a -> String) -> EventG t a -> EventG t a
+
+-- traceE shw = fmap (\ (t,a) -> trace (shw' t a) a) . withTimeGE
+-- where
+-- shw' t a = "time "++show t++": "++shw a
+
+-- traceE shw = fmap (\ (t,a) -> trace (shw' t) a) . withTimeGE
+-- where
+-- shw' t = "time "++show t++"\n"
+
+-- traceE shw = fmap (\ a -> trace (shw a) a)
+
+-- Something is wonky. Try this version, avoiding withTimeGE
+
+traceE shw ~(Event (Future (t,r))) =
+ Event (Future (trace ("time "++show t) t, traceR shw r))
+
+-- | Tracing of reactive values
+traceR :: Show t => (a -> String) -> Unop (ReactiveG t a)
+traceR shw ~(a `Stepper` e) = trace ("val: "++shw a) $
+ a `Stepper` traceE shw e
+-}
+
+-- I'm experimenting with lazy patterns here. They didn't help.
+-- When time tracing is on, mappends don't work. I think the problem is
+-- that show extracts *all* information from a time, while 'min' and
+-- '(<=)' don't. Of course: consider two future occurrences being
+-- compared. Before any outer info can be extracted, the trace will
+-- evaluate the whole time of a occurrence that hasn't happened yet.
+--
+-- To trace an event then, I really want to put partial traces into the
+-- times, which will have to work specially for the time type. Or I could
+-- make a Traceable class.
+
+{-
+
+-- | Make an event and a sink for feeding the event. Each value sent to
+-- the sink becomes an occurrence of the event.
+mkEvent :: Ord t => IO (EventG t a, SinkG t a)
+mkEvent = do (fut,handler) <- newFuture
+ -- remember how to save the next occurrence.
+ r <- newIORef handler
+ return (Event fut, writeTo r)
+ where
+ -- Fill in an occurrence while preparing for the next one
+ writeTo r fut = do handler <- readIORef r
+ (fut',handler') <- newFuture
+ writeIORef r handler'
+ handler $ fmap (`stepper` Event fut') fut
+
+-- TODO: replace IORefs by mvars. When I tried before, GuiTV input hung.
+
+-- | Tracing variant of 'mkEvent'
+mkEventTrace :: (Ord t, Show t) =>
+ (a -> String) -> IO (EventG t a, SinkG t a)
+mkEventTrace shw = second tr <$> mkEvent
+ where
+ tr handler = (putStrLn.shw') `mappend` handler
+ shw' (Future (t,a)) = "Occurrence at time "++show t++": "++shw a
+
+-- | Show specialization of 'mkEventTrace'
+mkEventShow :: (Ord t, Show t, Show a) => String -> IO (EventG t a, SinkG t a)
+mkEventShow str = mkEventTrace ((str ++).(' ':).show)
+
+-}
+
+-- | Get a future representing the first occurrence of the event together
+-- with the event of all occurrences after that one.
+eventOcc :: (Ord t) => EventG t a -> FutureG t (a, EventG t a)
+eventOcc (Event fut) = (\ (Stepper a e) -> (a,e)) <$> fut
+
+
+-- | 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
+-- may be re-displayed.
+rats :: Ord t => ReactiveG t a -> [t] -> [a] -- increasing times
+
+_ `rats` [] = []
+
+r@(a `Stepper` Event (Future (tr',r'))) `rats` ts@(t:ts')
+ | ftime t <= tr' = a : r `rats` ts'
+ | otherwise = r' `rats` ts
+
+-- Just for testing
+rat :: Ord t => ReactiveG t a -> t -> a
+rat r = head . rats r . (:[])
+
+
+{--------------------------------------------------------------------
+ Other instances
+--------------------------------------------------------------------}
+
+-- Standard instances
+instance (Monoid_f f, Ord t) => Monoid_f (ReactiveG t :. f) where
+ { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
+instance (Ord t, Pair f) => Pair (ReactiveG t :. f) where pair = apPair
+
+instance Unpair (ReactiveG t) where {pfst = fmap fst; psnd = fmap snd}
+
+-- Standard instances
+instance Ord t => Monoid_f (EventG t) where
+ { mempty_f = mempty ; mappend_f = mappend }
+instance Ord t => Monoid ((EventG t :. f) a) where
+ { mempty = O mempty; mappend = inO2 mappend }
+instance Ord t => Monoid_f (EventG t :. f) where
+ { mempty_f = mempty ; mappend_f = mappend }
+instance (Ord t, Copair f) => Pair (EventG t :. f) where
+ pair = copair
+
+-- Standard instance for functors
+instance Unpair (EventG t) where {pfst = fmap fst; psnd = fmap snd}
+
+
+{--------------------------------------------------------------------
+ To be moved elsewhere
+--------------------------------------------------------------------}
+
+-- | Pass through @Just@ occurrences.
+joinMaybes :: MonadPlus m => m (Maybe a) -> m a
+joinMaybes = (>>= maybe mzero return)
+
+-- | Pass through values satisfying @p@.
+filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
+filterMP p m = joinMaybes (liftM f m)
+ where
+ f a | p a = Just a
+ | otherwise = Nothing
+
+-- Alternatively:
+-- filterMP p m = m >>= guarded p
+-- where
+-- guarded p x = guard (p x) >> return x
+
+{--------------------------------------------------------------------
+ Tests
+--------------------------------------------------------------------}
+
+-- TODO: Define more types like ApTy, use in batch below. Move to checkers.
+type ApTy f a b = f (a -> b) -> f a -> f b
+
+batch :: TestBatch
+batch = ( "Reactive.PrimReactive"
+ , concatMap unbatch
+ [ ("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
+ -> EventG NumT NumT)
+ , monotonicity "join" (join
+ :: EventG NumT (EventG NumT T)
+ -> EventG NumT T)
+ , monotonicity "withTimeGE" (withTimeGE
+ :: EventG NumT T
+ -> EventG NumT (T, Time NumT))
+ , monotonicity "once" (once
+ :: EventG NumT T
+ -> EventG NumT T)
+ , monotonicity2 "accumE" (accumE
+ :: T
+ -> EventG NumT (T -> T)
+ -> EventG NumT T)
+ , monotonicity2 "mappend" (mappend
+ :: EventG NumT T
+ -> EventG NumT T
+ -> EventG NumT T)
+ , monotonicity2 "mplus" (mplus
+ :: EventG NumT T
+ -> EventG NumT T
+ -> EventG NumT T)
+ , monotonicity2 "<|>" ((<|>)
+ :: EventG NumT T
+ -> EventG NumT T
+ -> EventG NumT T)
+ , monotonicity2 "fmap" (fmap
+ :: (T -> T)
+ -> EventG NumT T
+ -> EventG NumT T)
+-- ,monotonicity2 "flip (>>=)" (flip (>>=))
+-- ,monotonicity2 (flip snapshot) "flip snapshot"
+ ])
+ , ("order preservation",
+ [ simulEventOrder "once" (once
+ :: 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)]
+-- )
+ ]
+ )
+
+-- joinEOccuranceCount :: Property
+-- joinEOccuranceCount =
+-- forAll (finiteEvent $ finiteEvent arbitrary
+-- :: Gen (EventG NumT (EventG NumT T)))
+-- ((==) <$> (sum . map (length . toListE_) . toListE_)
+-- <*> (length . toListE_ . joinE))
+
+{-
+toListE :: EventG t a -> [FutureG t a]
+toListE (Event (Future (Max MaxBound, _ ))) = []
+toListE (Event (Future (t0 , v `Stepper` e'))) = Future (t0,v) : toListE e'
+
+toListE_ :: EventG t a -> [a]
+toListE_ = map futVal . toListE
+-}
+
+monotonicity :: (Show a, Arbitrary a, Arbitrary t
+ ,Num t, Ord t, Ord 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')
+ => 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 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')
+ => (b -> EventG t a -> EventG t' a')
+ -> (b , EventG t a) -> Bool
+monotoneTest2 f (x,e) =
+ unsafePerformIO ( (evaluate (isMonotoneE (x `f` e)))
+ `race` slowTrue)
+
+slowTrue :: IO Bool
+slowTrue = do threadDelay 10
+ return True
+
+-- 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)
+ ((uncurry isMonotoneR') . unFuture . eFuture)
+
+isMonotoneE' :: (Ord t) => (Time t) -> EventG t a -> Bool
+isMonotoneE' t =
+ liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ ((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture)
+
+isMonotoneR :: (Ord t) => ReactiveG t a -> Bool
+isMonotoneR (_ `Stepper` e) = isMonotoneE e
+
+isMonotoneR' :: (Ord 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''')
+ => 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)
+ => 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 =
+ liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ (isStillOrderedR . futVal . eFuture)
+
+ isStillOrderedR (a `Stepper` e) =
+ isStillOrderedE' a e
+
+ isStillOrderedE' a =
+ liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ (isStillOrderedR' a . futVal . eFuture)
+
+ isStillOrderedR' a (b `Stepper` e) =
+ a < b && isStillOrderedE' b e
+
+-- An event to test with that is infinite
+infE :: EventG NumT NumT
+infE = futuresE (zipWith future [1..] [1..])
diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs
new file mode 100755
index 0000000..0cf71bf
--- /dev/null
+++ b/src/FRP/Reactive/Reactive.hs
@@ -0,0 +1,292 @@
+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, TypeOperators, FlexibleInstances #-}
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : FRP.Reactive.Reactive
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Simple reactive values. Adds some extra functionality on top of
+-- "FRP.Reactive.PrimReactive"
+----------------------------------------------------------------------
+
+module FRP.Reactive.Reactive
+ (
+ module FRP.Reactive.PrimReactive
+ , TimeT, ITime, Future
+ , traceF
+ -- * Event
+ , Event
+ , withTimeE
+ , atTime, atTimes, listE
+ , {-mbsEvent,-} pairE, scanlE, monoidE
+ , withPrevE, withPrevEWith
+ , stateE, stateE_, countE, countE_, diffE
+ -- * Reactive values
+ , Reactive
+ , Source
+ , snapshot_, snapshot, whenE
+ , scanlR, monoidR, eitherE, maybeR, flipFlop, countR
+ , splitE, switchE
+ , integral, sumR
+ -- * Re-export
+ , exact
+ -- * Tests
+ , batch
+ ) where
+
+import Control.Applicative
+import Control.Arrow (first,second)
+import Control.Monad
+import Data.Monoid
+import Debug.Trace (trace)
+
+-- import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes ()
+
+-- vector-space
+import Data.VectorSpace
+
+-- TypeCompose
+import Data.Pair (pairEdit)
+
+import Data.Max
+import Data.AddBounds
+import FRP.Reactive.Future hiding (batch)
+import FRP.Reactive.PrimReactive hiding (batch)
+import FRP.Reactive.Improving
+
+-- | The type of finite time values.
+type TimeT = Double
+
+-- | Improving doubles, as used for time values in 'Event', 'Reactive',
+-- and 'ReactiveB'.
+type ITime = Improving TimeT
+
+-- | Type of future values. Specializes 'FutureG'.
+type Future = FutureG ITime
+
+-- -- | Sink, e.g., for an event handler
+-- type Sink a = SinkG Time a
+
+
+-- | Trace the elements of a functor type.
+traceF :: Functor f => (a -> String) -> f a -> f a
+traceF shw = fmap (\ a -> trace (shw a) a)
+
+-- traceShowF :: (Functor f,Show a) => f a -> f a
+-- traceShowF = traceF show
+
+
+{--------------------------------------------------------------------
+ Events
+--------------------------------------------------------------------}
+
+-- | Events, specialized to improving doubles for time
+type Event = EventG ITime
+
+-- | Access occurrence times in an event. See 'withTimeGE' for more
+-- general notions of time.
+withTimeE :: Event a -> Event (a, TimeT)
+withTimeE e = second (exact.timeT) <$> withTimeGE e
+
+timeT :: Ord t => Time 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
+
+-- | Event occuring at given times. See also 'atTime' and 'atTimeG'.
+atTimes :: [TimeT] -> Event ()
+atTimes = atTimesG . fmap exactly
+
+-- | 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)
+
+-- | 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
+
+-- | Like 'scanl' for events.
+scanlE :: Ord 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 = scanlE mappend mempty
+
+-- | Pair each event value with the previous one. The second result is
+-- 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 e = (joinMaybes . fmap combineMaybes) $
+ (Nothing,Nothing) `accumE` fmap (shift.Just) e
+ where
+ -- Shift newer value into (old,new) pair if present.
+ shift :: u -> (u,u) -> (u,u)
+ shift new (old,_) = (new,old)
+ 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 f e = fmap (uncurry f) (withPrevE 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)
+ where
+ b0 = error "stateE: 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
+
+-- stateE_ s0 f e = snd <$> stateE 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)
+
+-- | 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_ 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)
+
+-- -- | Returns an event whose occurrence's value corresponds with the input
+-- -- event's previous occurence's value.
+-- delayE :: Event a -> Event a
+-- delayE = withPrevEWith (flip const)
+
+-- I suspect that delayE will only be used to hide implementation
+-- problems, so I removed it. - Conal
+
+{--------------------------------------------------------------------
+ Reactive extras (defined via primitives)
+--------------------------------------------------------------------}
+
+-- | Reactive values, specialized to improving doubles for time
+type Reactive = ReactiveG ITime
+
+-- | Compatibility synonym (for ease of transition from DataDriven)
+type Source = Reactive
+
+
+-- | Snapshot a reactive value whenever an event occurs.
+snapshot :: Ord t => EventG t a -> ReactiveG t b -> EventG t (a,b)
+snapshot = snapshotWith (,)
+
+-- | Like 'snapshot' but discarding event data (often @a@ is '()').
+snapshot_ :: Ord t => EventG t a -> ReactiveG t b -> EventG t b
+snapshot_ = snapshotWith (flip const)
+
+-- Alternative implementations
+-- e `snapshot_` src = snd <$> (e `snapshot` src)
+-- snapshot_ = (fmap.fmap.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 e = joinMaybes . fmap h . 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 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 = 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 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 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 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 e = 0 `stepper` countE_ e
+
+-- | Partition an event into segments.
+splitE :: Ord t => EventG t a -> EventG t b -> EventG t (a, EventG t b)
+ea `splitE` eb = h <$> (withRestE ea `snapshot` remainderR eb)
+ 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 :: Event (Event a) -> Event a
+switchE = join . fmap (uncurry untilE) . withRestE
+
+
+-- | Euler integral.
+integral :: forall v t. (Num t, VectorSpace v t) =>
+ t -> Event t -> Reactive v -> Reactive v
+integral t0 newT r = sumR (snapshotWith (*^) deltaT r)
+ where
+ deltaT :: Event 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 :: VectorSpace v s => Event v -> Reactive v
+sumR = scanlR (^+^) zeroV
+
+
+{----------------------------------------------------------
+ Tests
+----------------------------------------------------------}
+
+batch :: TestBatch
+batch = ( "FRP.Reactive.Reactive"
+ , concatMap unbatch
+ [
+ -- Write some tests!
+ ]
+ )
diff --git a/src/FRP/Reactive/SImproving.hs b/src/FRP/Reactive/SImproving.hs
new file mode 100755
index 0000000..dedb830
--- /dev/null
+++ b/src/FRP/Reactive/SImproving.hs
@@ -0,0 +1,173 @@
+{-# OPTIONS -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.SImproving
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy
+-- in an Abstract Data Type with Deterministic Semantics\".
+--
+-- This implementation is simple but not efficient, as it accumulates lots
+-- of lower bounds.
+----------------------------------------------------------------------
+
+module Reactive.SImproving
+ (
+ Improving(..), exactly, exact, improveMbs
+ -- * Misc speculation tools
+ , spec, specNY, specYY, start
+ ) where
+
+import Data.Function (on)
+-- import Debug.Trace
+
+import Control.Parallel (par)
+
+-- | Progressive information about a value (e.g., a time). Represented as
+-- a non-empty list of monotonically non-decreasing values. The last one
+-- is the actual value. (The operations here ensure that the values are
+-- strictly increasing, but they only rely on non-decreasing.)
+newtype Improving a = Imp { unImp :: [a] } deriving Show
+
+-- | Apply a unary function inside an 'Improving' representation.
+inImp :: ([a] -> [b]) -> (Improving a -> Improving b)
+inImp f = Imp . f . unImp
+
+-- | Apply a unary function inside an 'Improving' representation.
+inImp2 :: ([a] -> [b] -> [c]) -> (Improving a -> Improving b -> Improving c)
+inImp2 f = inImp . f . unImp
+
+-- | A known improving value (which doesn't really improve)
+exactly :: Ord a => a -> Improving a
+exactly = Imp . (:[])
+
+-- | Extract an exact value from an improving value
+exact :: Improving a -> a
+exact = last . unImp
+
+instance Eq a => Eq (Improving a) where
+ (==) = (==) `on` exact
+
+instance Ord a => Ord (Improving a) where
+ Imp xs `compare` Imp ys = -- trace "Improving: compare" $
+ xs `compares` ys
+ -- experimental. probably eliminate.
+ Imp xs <= Imp ys = xs `leq` ys
+ min = inImp2 shortMerge
+ max = inImp2 (specNY monotonicAppend)
+
+-- This one wasn't in the Improving Values papers. Here so that
+-- 'compare', '(<=)', etc are defined on Improving.
+compares :: Ord a => [a] -> [a] -> Ordering
+compares [] _ = error "compares: emptied first argument"
+compares _ [] = error "compares: emptied second argument"
+compares [x] (y:_) | x < y = LT
+compares (x:_) [y] | x > y = GT
+compares [x] [y] = compare x y
+-- we know x >= y and length ys >= 2
+compares xs@[_] (_:ys') = compares xs ys'
+-- we know x <= y and length xs >= 2
+compares (_:xs') ys@[_] = compares xs' ys
+-- neither list is down to last element. progress where less is known.
+compares xs@(x:xs') ys@(y:ys') | x == y = compares xs' ys'
+ | x < y = compares xs' ys
+ | otherwise = compares xs ys'
+
+-- Hm! The test I really want is (<=), which can get an answer based on
+-- slightly less information than compares.
+
+leq :: Ord a => [a] -> [a] -> Bool
+leq [] _ = error "leq: emptied first argument"
+leq _ [] = error "leq: emptied second argument"
+leq [x] (y:_) | x <= y = True
+leq (x:_) [y] | x > y = False
+leq [x] [y] = x <= y
+-- we know x > y and length ys >= 2
+leq xs@[_] (_:ys') = leq xs ys'
+-- we know x <= y and length xs >= 2
+leq (_:xs') ys@[_] = leq xs' ys
+-- neither list is down to last element. progress where less is known.
+leq xs@(x:xs') ys@(y:ys') | x == y = leq xs' ys'
+ | x < y = leq xs' ys
+ | otherwise = leq xs ys'
+
+-- leq didn't fix the bug I'm finding in phooey (src/Examples/Monad, t5)
+-- when using SReactive instead of PrimReactive in Data/Reactive.
+-- Probably remove leq later.
+
+
+shortMerge :: Ord a => [a] -> [a] -> [a]
+shortMerge [] _ = []
+shortMerge _ [] = []
+shortMerge xs@(x:xs') ys@(y:ys')
+ | x == y = x : shortMerge xs' ys'
+ | x < y = x : shortMerge xs' ys
+ | otherwise = y : shortMerge xs ys'
+
+monotonicAppend :: Ord a => [a] -> [a] -> [a]
+-- monotonicAppend [x] ys = x : dropWhile (<= x) ys
+-- monotonicAppend (x:xs') ys = x : monotonicAppend xs' ys
+-- monotonicAppend [] _ = error "monotonicAppend: empty list"
+
+-- From "Encapsulating nondeterminacy in an abstract data type with
+-- deterministic semantics"
+monotonicAppend xs ys = xs ++ dropWhile (<= last xs) ys
+
+
+-- TODO: consider trimming ys as we go, rather than later. However, I
+-- have a fuzzy understanding of why spec_max and not just max in the
+-- papers.
+
+-- | Interpret 'Nothing' values as lower bounds
+improveMbs :: [(t, Maybe a)] -> [(Improving t, a)]
+improveMbs = foldr f []
+ where
+ f (t,Just a ) qs = (Imp [t],a) : qs
+ f (t,Nothing) ~((Imp ts', a) : qs') = (Imp (t:ts'), a) : qs'
+ -- f (_,Nothing) [] = error "improveMbs: input ends in a Nothing"
+
+-- The lazy pattern (~) above is essential for laziness. It also
+-- complicates giving an error message if the input ends in a Nothing.
+
+-- improveMbs [] = []
+-- improveMbs ((t,Just a ) : ps') = (Imp [{-tr True-} t],a) : improveMbs ps'
+-- improveMbs ((t,Nothing) : ps') = (Imp ({-tr False-} t:ts'), a) : qs'
+-- where
+-- (Imp ts', a) : qs' = improveMbs ps'
+
+-- tr :: (Show x, Show t) => x -> t -> t
+-- tr x t = t
+-- -- trace (show (t, x)) t
+
+-- improveMbs = foldr f []
+-- where
+-- f (t,Just a ) qs = (Imp [t],a) : qs
+-- f (t,Nothing) qs =
+-- case qs of ((Imp ts', a) : qs') -> (Imp (t:ts'), a) : qs'
+-- [] -> error "improveMbs: input ends in a Nothing"
+
+-- TODO: re-think the case of input ending in a Nothing.
+
+
+---- Misc
+
+spec :: (a -> b) -> (a -> b)
+spec f a = a `par` f a
+
+specNY :: (a -> b -> c) -> (a -> b -> c)
+specNY f a = spec (f a)
+
+specYY :: (a -> b -> c) -> (a -> b -> c)
+specYY f a = spec (spec f a)
+
+start :: [a] -> [a]
+start [] = []
+start (x:xs) = specYY (:) x (start xs)
+
+-- Hm. Does this specNY really do anything? How far does 'par' evaluate?
+-- Probably to WHNF, which wouldn't help much, would it? And I don't
+-- understand the point yet. Read further in the paper.
diff --git a/src/FRP/Reactive/Sorted.hs b/src/FRP/Reactive/Sorted.hs
new file mode 100755
index 0000000..e3e8ec4
--- /dev/null
+++ b/src/FRP/Reactive/Sorted.hs
@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -Wall #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Sorted
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Sorted lists: experimental (unused)
+----------------------------------------------------------------------
+
+module Reactive.Sorted where
+
+import Data.Monoid
+import Data.List (sort)
+import Control.Applicative
+import Control.Monad
+
+newtype Sorted a = Sort { unSort :: [a] } -- non-decreasing values
+
+-- | Apply a unary function within the event representation.
+inSort :: ([a] -> [b]) -> (Sorted a -> Sorted b)
+inSort f = Sort . f . unSort
+
+-- | Apply a binary function within the event representation.
+inSort2 :: ([a] -> [b] -> [c]) -> (Sorted a -> Sorted b -> Sorted c)
+inSort2 f = inSort . f . unSort
+
+
+instance Ord a => Monoid (Sorted a) where
+ mempty = Sort []
+ mappend = inSort2 merge
+
+-- | Merge two ordered lists into an ordered list.
+merge :: Ord a => [a] -> [a] -> [a]
+[] `merge` vs = vs
+us `merge` [] = us
+us@(u:us') `merge` vs@(v:vs') =
+ (u `min` v) : if u <= v then us' `merge` vs else us `merge` vs'
+
+-- Alternatively,
+--
+-- us@(u:us') `merge` vs@(v:vs') =
+-- if u <= v then
+-- u : (us' `merge` vs )
+-- else
+-- v : (us `merge` vs')
+--
+-- The definition used instead is more productive. It produces a cons
+-- cell immediately and can even produce partial information about @u
+-- `min` v@ before it's known which is smaller.
+
+class FunctorOrd h where
+ fmapO :: (Ord a, Ord b) => (a -> b) -> h a -> h b
+
+class FunctorOrd h => ApplicativeOrd h where
+ pureO :: Ord a => a -> h a
+ (<*?>) :: (Ord a, Ord b) => h (a -> b) -> h a -> h b
+
+class MonadOrd h where
+ returnO :: Ord a => a -> h a
+ -- does joinO need Ord (h a) ?
+ joinO :: Ord a => h (h a) -> h a
+
+instance FunctorOrd Sorted where
+ fmapO f = inSort (sort . fmap f)
+
+instance ApplicativeOrd Sorted where
+ pureO a = Sort (pure a)
+ (<*?>) = inSort2 $ (fmap.fmap) sort (<*>)
+
+instance MonadOrd Sorted where
+ returnO = pureO
+ joinO = inSort $ sort . join . fmap unSort
diff --git a/src/FRP/Reactive/VectorSpace.hs b/src/FRP/Reactive/VectorSpace.hs
new file mode 100755
index 0000000..a3f0972
--- /dev/null
+++ b/src/FRP/Reactive/VectorSpace.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+
+module FRP.Reactive.VectorSpace( ) where
+
+import FRP.Reactive.Behavior
+import Control.Applicative
+
+import Data.VectorSpace
+import Data.AdditiveGroup
+
+instance AdditiveGroup v => AdditiveGroup (Behavior v) where
+ zeroV = pure zeroV
+ (^+^) = liftA2 (^+^)
+ negateV = liftA negateV
+
+instance VectorSpace v s => VectorSpace (Behavior v) s where
+ (*^) s = fmap (s *^)
diff --git a/src/Test/Reactive.hs b/src/Test/Reactive.hs
new file mode 100755
index 0000000..aa0ba40
--- /dev/null
+++ b/src/Test/Reactive.hs
@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Test.TestReactive
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Gather up QuickCheck tests for Reactive
+----------------------------------------------------------------------
+
+module Test.Reactive (batches,main) where
+
+import Test.QuickCheck.Checkers
+
+-- import qualified Data.Unamb
+
+import qualified FRP.Reactive.Future
+import qualified FRP.Reactive.PrimReactive
+import qualified FRP.Reactive.Reactive
+import qualified FRP.Reactive.Fun
+
+batches :: [TestBatch]
+batches = [ FRP.Reactive.Future.batch
+ , FRP.Reactive.PrimReactive.batch
+ , FRP.Reactive.Reactive.batch
+ , FRP.Reactive.Fun.batch
+ ]
+
+main :: IO ()
+main = mapM_ quickBatch batches