packages feed

reactive 0.5.0.1 → 0.8.3

raw patch · 37 files changed

+3455/−949 lines, 37 filesdep +QuickCheckdep +checkersdep +old-timedep ~TypeComposedep ~base

Dependencies added: QuickCheck, checkers, old-time, random, unamb, vector-space

Dependency ranges changed: TypeCompose, base

Files

+ Makefile view
@@ -0,0 +1,9 @@+# For special configuration, especially for docs.  Otherwise see README.++server = code.haskell.org+server-dir = /srv/code+server-url-dir =++# extra-configure-args += --enable-library-profiling --enable-executable-profiling++include ../my-cabal-make.inc
+ README view
@@ -0,0 +1,34 @@+_Reactive_ [1] is a simple foundation for programming reactive systems+functionally.  Like Fran/FRP, it has a notions of (reactive) behaviors and+events.  Like DataDriven [2], Reactive has a data-driven implementation.++The inspiration for Reactive was Mike Sperber's Lula [3] implementation of+FRP.  Mike used blocking threads, which I had never considered for FRP.+While playing with the idea, I realized that I could give a very elegant+and efficient solution to caching, which DataDriven doesn't do.  (For an+application "f <*> a" of a varying function to a varying argument, caching+remembers the latest function to apply to a new argument and the last+argument to which to apply a new function.)++The theory and implementation of Reactive are described in the paper "Simply+efficient functional reactivity" [4].++Please share any comments & suggestions on the discussion (talk) page [1].++Note that cabal[5], version 1.4.0.1 or greater is required for installation.++You can configure, build, and install all in the usual way with Cabal+commands.++  runhaskell Setup.lhs configure+  runhaskell Setup.lhs build+  runhaskell Setup.lhs install+++References:++[1] http://haskell.org/haskellwiki/Reactive+[2] http://haskell.org/haskellwiki/DataDriven+[3] http://www-pu.informatik.uni-tuebingen.de/lula/deutsch/publications.html+[4] http://conal.net/papers/simply-reactive+[5] http://www.haskell.org/cabal/download.html
+ TODO view
@@ -0,0 +1,19 @@+For next release:+++ Move all of the legacy-adapter stuff to a new LegacyAdapter directory.+  Use David's boingeeFieldTrip adapter as a basis.  Separate out all of+  the GLUT stuff.+++ Much-simplified interfaces.  FRP.Reactive has just behaviors and events.+  FRP.Reactive.LegacyAdapter for building legacy adapters.+++ Something for accessing representations but not exposed in FRP.Reactive.++----++Beyond:+++ Revisit choice of time as double.  Consider nanoseconds or microseconds+  instead, for regularity of time-stepping.+++ Semantics-based fusion rules.  Inquire about fusion vs sharing.
+ changes.tw view
@@ -0,0 +1,29 @@+== Version 0 ==++=== Version 0.8 ===++=== Version 0.8.1 ===++* Adding QuickCheck tests.++''Fill in missing versions''+++=== Version 0.3 ===++* Commented out LANGUAGE pragmas and added OPTIONS_GHC -fglasgow-exts for ghc-6.6 compatibility.++=== Version 0.2 ===++* Fixed <hask>switcher</hask>.  Didn't terminate.  Thanks to Ivan Tomac for the bug report.++=== Version 0.1 ===++* Added <hask>Never</hask> constructor for Future.  Allows optimizations, including a huge improvement for <hask>(>>=)</hask> on <hask>Event</hask> (which had been piling up <hask>never</hask>s).+* removed <code>-threaded</code> comment+* added <hask>traceR</hask> (reactive value tracing)+* use idler in <code>src/Examples.hs</code> (for single-threaded use of wxHaskell)++=== Version 0.0 ===++* New project.
reactive.cabal view
@@ -1,42 +1,67 @@ Name:                reactive-Version:             0.5.0.1-Synopsis: 	     Simple foundation for functional reactive programming+Version:             0.8.3+Synopsis:            Simple foundation for functional reactive programming Category:            reactivity, FRP Description:   /Reactive/ is a simple foundation for programming reactive systems   functionally.  Like Fran\/FRP, it has a notions of (reactive) behaviors and-  events.  Like DataDriven, Reactive has a data-driven implementation.-  The main difference between Reactive and DataDriven is that Reactive-  builds on functional \"futures\" (using threading), while DataDriven-  builds on continuation-based computations.+  events.  Unlike most previous FRP implementations, Reactive has a hybrid+  demand/data-driven implementation, as described in the paper \"Simply+  efficient functional reactivity\", <http://conal.net/papers/simply-reactive/>.   .   Please see the project wiki page: <http://haskell.org/haskellwiki/reactive>   .   The module documentation pages have links to colorized source code and   to wiki pages where you can read and contribute user comments.  Enjoy!   .-  &#169; 2007 by Conal Elliott; BSD3 license.+  &#169; 2007-2008 by Conal Elliott; BSD3 license. Author:              Conal Elliott  Maintainer:          conal@conal.net Homepage:            http://haskell.org/haskellwiki/reactive-Package-Url:	     http://darcs.haskell.org/packages/reactive+Package-Url:         http://code.haskell.org/reactive Copyright:           (c) 2007-2008 by Conal Elliott+Cabal-Version:       >= 1.2 License:             BSD3 Stability:           provisional-build-type:	     Simple-Hs-Source-Dirs:      src-Extensions:          -Build-Depends:       base >= 3.0.3.2 && < 5, TypeCompose>=0.6.7-Exposed-Modules:     -		     Data.SFuture-		     Data.Future-		     Data.Fun-		     Data.Reactive+Build-Type:          Simple Extra-Source-Files:-ghc-options:         -Wall+Library+    Build-Depends:       base, old-time, random, QuickCheck < 2.0,+                         TypeCompose>=0.3, vector-space, unamb, checkers+    -- This library uses the ImpredicativeTypes flag, and it depends+    -- on vector-space, which needs ghc >= 6.9+    if impl(ghc < 6.9) {+      buildable: False+    }+    Hs-Source-Dirs:      src+    Exposed-Modules:     +        FRP.Reactive --- Experimental modules:--- 		     Data.SEvent--- 		     Data.MEvent--- 		     Data.EventExtras--- 		     Data.SReactive+        FRP.Reactive.Future+        FRP.Reactive.PrimReactive+        FRP.Reactive.Reactive+        FRP.Reactive.Behavior+        FRP.Reactive.Fun+        FRP.Reactive.Improving+        FRP.Reactive.Num+        FRP.Reactive.VectorSpace++        -- FRP.Reactive.LegacyAdapters++        FRP.Reactive.Internal.Misc+        FRP.Reactive.Internal.Fun+        FRP.Reactive.Internal.Future+        FRP.Reactive.Internal.Reactive+        FRP.Reactive.Internal.Behavior+        FRP.Reactive.Internal.Clock+        FRP.Reactive.Internal.Timing++        Data.AddBounds+        Data.Min+        Data.Max+        Data.PairMonad+        -- Probably eliminate the next few+        FRP.Reactive.Internal.IVar+        FRP.Reactive.Internal.Serial+        FRP.Reactive.Internal.TVal+    ghc-options:         -Wall
+ src/Data/AddBounds.hs view
@@ -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
− src/Data/Fun.hs 
@@ -1,62 +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 qualified Control.Category (Category, (.), id)-import Control.Arrow (Arrow, arr, first, second, (***), (>>>))---- | 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 Control.Category.Category Fun where-  id          = arr id-  K b   . _   = K   b-  Fun g . K a = K   (g a)-  Fun f . Fun g = Fun (f . g)--instance Arrow Fun where-  arr             = Fun-  first           = Fun . first  . apply-  second          = Fun . second . apply-  K a'  *** K b'  = K (a',b')-  f     *** g     = first f >>> second g
− src/Data/Future.hs 
@@ -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
+ src/Data/Max.hs view
@@ -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)
+ src/Data/Min.hs view
@@ -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)
+ src/Data/PairMonad.hs view
@@ -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?
− src/Data/Reactive.hs 
@@ -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 {fsts = fmap fst; snds = 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 {fsts = fmap fst; snds = 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
− src/Data/SFuture.hs 
@@ -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
+ src/Examples.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE TypeOperators, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}++----------------------------------------------------------------------+-- |+-- Module      :  Examples+-- Copyright   :  (c) Conal Elliott 2007+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Simple test for Reactive+----------------------------------------------------------------------++-- module Main where++-- base+import Data.Monoid+import Data.IORef+import Control.Monad+import Control.Applicative+import Control.Arrow (first,second)+import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId)++-- wxHaskell+import Graphics.UI.WX hiding (Event,Reactive)+import qualified Graphics.UI.WX as WX+-- TypeCompose+import Control.Compose ((:.)(..), inO,inO2)+import Data.Title++-- Reactive+import Reactive.Reactive+++{--------------------------------------------------------------------+    Mini-Phooey+--------------------------------------------------------------------}++type Win = Panel ()++type Wio = ((->) Win) :. IO :. (,) Layout++type Wio' a = Win -> IO (Layout,a)+++wio :: Wio' a -> Wio a+wio = O . O++unWio :: Wio a -> Wio' a+unWio = unO . unO++inWio :: (Wio' a -> Wio' b) -> (Wio a -> Wio b)+inWio f = wio . f . unWio++inWio2 :: (Wio' a -> Wio' b -> Wio' c) -> (Wio a -> Wio b -> Wio c)+inWio2 f = inWio . f . unWio++instance Title_f Wio where+  title_f str = inWio ((fmap.fmap.first) (boxed str))++-- Bake in vertical layout.  See phooey for flexible layout.+instance Monoid Layout where+  mempty  = WX.empty+  mappend = above++instance Monoid a => Monoid (Wio a) where+  mempty  = wio    mempty+  mappend = inWio2 mappend++type WioE a = Wio (Event    a)+type WioR a = Wio (Reactive a)++buttonE :: String -> WioE ()+buttonE str = wio $ \ win ->+  do (e, snk) <- mkEvent+     b <- button win [ text := str, on command := snk () ]+     return (hwidget b, e)++buttonE' :: String -> a -> WioE a+buttonE' str a = (a `replace`) <$> buttonE str++sliderE :: (Int,Int) -> Int -> WioE Int+sliderE (lo,hi) initial = wio $ \ win ->+  do (e, snk) <- mkEvent+     s <- hslider win True lo hi+            [ selection := initial ]+     set s [ on command := getAttr selection s >>= snk ]+     return (hwidget s, e)++sliderR :: (Int,Int) -> Int -> WioR Int+sliderR lh initial = stepper initial <$> sliderE lh initial++stringO :: Wio (Sink String)+stringO = attrO (flip textEntry []) text++-- Make an output.  The returned sink collects updates.  On idle, the+-- latest update gets stored in the given attribute.+attrO :: Widget w => (Win -> IO w) -> Attr w a -> Wio (Sink a)+attrO mk attr = wio $ \ win ->+  do ctl <- mk win+     ref <- newIORef Nothing+     setAttr (on idle) win $+       do readIORef ref >>= maybe mempty (setAttr attr ctl)+          writeIORef ref Nothing+          return True+     return (hwidget ctl , writeIORef ref . Just)++-- -- The following alternative ought to be more efficient.  Oddly, the timer+-- -- doesn't get restarted, although enabled gets set to True.++-- stringO = wio $ \ win ->+--   do ctl <- textEntry win []+--      ref <- newIORef (error "stringO: no initial value")+--      tim <- timer win [ interval := 10, enabled := False ]+--      let enable b = do putStrLn $ "enable: " ++ show b+--                        setAttr enabled tim b+--      set tim [ on command := do putStrLn "timer"+--                                 readIORef ref >>= setAttr text ctl+--                                 enable False+--              ]+--      return ( hwidget ctl+--             , \ str -> writeIORef ref str >> enable True )++showO :: Show a => Wio (Sink a)+showO = (. show) <$> stringO++showR :: Show a => WioR (Sink a)+showR = pure <$> showO+++-- | Horizontally-filled widget layout+hwidget :: Widget w => w -> Layout+hwidget = hfill . widget++-- | Binary layout combinator+above, leftOf :: Layout -> Layout -> Layout+la `above`   lb = fill (column  0 [la,lb])+la `leftOf`  lb = fill (row     0 [la,lb])++-- |  Get attribute.  Just a flipped 'get'.  Handy for partial application.+getAttr :: Attr w a -> w -> IO a+getAttr = flip get++-- | Set a single attribute.  Handy for partial application.+setAttr :: Attr w a -> w -> Sink a+setAttr attr ctl x = set ctl [ attr := x ]+++{--------------------------------------------------------------------+    Running+--------------------------------------------------------------------}++-- | Fork a 'Wio': handle frame & widget creation, and apply layout.+forkWio :: (o -> IO ThreadId) -> String -> Wio o -> IO ()+forkWio forker name w = start $+  do  f     <- frame [ visible := False, text := name ]+      pan   <- panel f []+      (l,o) <- unWio w pan+      set pan [ layout := l ]+      forker o+      -- Yield regularly, to allow other threads to continue.  Unnecessary+      -- when apps are compiled with -threaded.+      -- timer pan [interval := 10, on command := yield]+      set f   [ layout  := fill (widget pan)+              , visible := True+              ]++-- | Fork a 'WioE'+forkWioE :: String -> WioE Action -> IO ()+forkWioE = forkWio forkE++-- | Fork a 'WioR'+forkWioR :: String -> WioR Action -> IO ()+forkWioR = forkWio forkR+++{--------------------------------------------------------------------+    Examples+--------------------------------------------------------------------}++alarm :: Double -> Int -> IO (Event Int)+alarm secs reps =+  do (e,snk) <- mkEvent+     forkIO $ forM_ [1 .. reps] $ \ i ->+               do threadDelay micros+                  snk i+     return e+ where+   micros = round (1.0e6 * secs)+                          ++t0 = alarm 0.5 10 >>= \ e -> runE $ print <$> {-traceE (const "boo!")-} e++mkAB :: WioE String+mkAB = buttonE' "a" "a" `mappend` buttonE' "b" "b"+++t1 = forkWioE "t1" $ liftA2 (<$>) stringO mkAB++acc :: WioE String+acc = g <$> mkAB+ where+   g :: Event String -> Event String+   g e = "" `accumE` (flip (++) <$> e)++t2 = forkWioE "t2" $ liftA2 (<$>) stringO acc++total :: Show a => WioR (Sink a)+total = title "total" showR++sl :: Int -> WioR Int+sl = sliderR (0,100)++apples, bananas, fruit :: WioR Int+apples  = title "apples"  $ sl 3+bananas = title "bananas" $ sl 7+fruit   = title "fruit"   $ (liftA2.liftA2) (+) apples bananas++t3 = forkWioR "t3" $ liftA2 (<**>) fruit total ++t4 = forkWioR "t4" $ liftA2 (<*>) showR (sl 0)++t5 = forkWioR "t5" $ liftA2 (<$>) showO (sl 0)++-- This example shows what happens with expensive computations.  There's a+-- lag between slider movement and shown result.  Can even get more than+-- one computation behind.+t6 = forkWioR "t6" $ liftA2 (<$>) showO (fmap (ack 2) <$> sliderR (0,1000) 0)++ack 0 n = n+1+ack m 0 = ack (m-1) 1+ack m n = ack (m-1) (ack m (n-1))++-- Test switchers.  Ivan Tomac's example.+sw1 = do (e, snk) <- mkEvent+         forkR $ print <$> pure "init" `switcher` ((\_ -> pure "next") <$> e)+         snk ()+         snk ()++-- TODO: replace sw1 with a declarative GUI example, say switching between+-- two different previous GUI examples.++main = t6+++updPair :: Either c d -> (c,d) -> (c,d)+updPair = (first.const) `either` (second.const)++-- updPair (Left  c') (_,d) = (c',d)+-- updPair (Right d') (c,_) = (c,d')++-- mixEither :: (Event c, Event d) -> Event (Either c d)+-- mixEither :: (Functor f, Monoid (f (Either a b))) =>+--               (f a, f b) -> f (Either a b)+mixEither :: MonadPlus m => (m a, m b) -> m (Either a b)+mixEither (ec,ed) = liftM Left ec `mplus` liftM Right ed++-- unmixEither :: Event (Either c d) -> (Event c, Event d)+unmixEither :: MonadPlus m => m (Either c d) -> (m c, m d)+unmixEither ecd = (filt left, filt right)+ where+   filt f = joinMaybes (liftM f ecd)++left :: Either c d -> Maybe c+left (Left  c) = Just c+left _         = Nothing++right :: Either c d -> Maybe d+right (Right d) = Just d+right _         = Nothing+++-- pairEditE :: (Event c, Event d) -> Event ((c,d) -> (c,d))++-- pairEditE :: (Functor f, Monoid (f ((d, a) -> (d, a)))) =>+--              (f d, f a) -> f ((d, a) -> (d, a))+-- pairEditE (ce,de) =+--   ((first.const) <$> ce) `mappend` ((second.const) <$> de)++-- pairEditE :: (Functor m, MonadPlus m) => (m d, m a) -> m ((d, a) -> (d, a))+-- pairEditE (ce,de) =+--   ((first.const) <$> ce) `mplus` ((second.const) <$> de)++pairEditE :: MonadPlus m => (m c,m d) -> m ((c,d) -> (c,d))+pairEditE = liftM updPair . mixEither++-- pairEditE cde = liftM updPair (mixEither cde)++-- or, skipping sums++-- pairEditE (ce,de) =+--   liftM (first.const) ce `mplus` liftM (second.const) de++pairE :: (c,d) -> (Event c, Event d) -> Event (c,d)+pairE cd cde = cd `accumE` pairEditE cde++pairR :: Reactive c -> Reactive d -> Reactive (c,d)++-- (c `Stepper` ce) `pairR` (d `Stepper` de) =+--   (c,d) `stepper` pairE (c,d) (ce,de)++-- More directly:++(c `Stepper` ce) `pairR` (d `Stepper` de) =+  (c,d) `accumR` pairEditE (ce,de)++-- pairR' :: Reactive c -> Reactive d -> Reactive (c,d)+-- (c `Stepper` ce) `pairR'` (d `Stepper` de) =+--   (c,d) `accumR` pairEditE (ce,de)+
+ src/FRP/Reactive.hs view
@@ -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
+ src/FRP/Reactive/Behavior.hs view
@@ -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.
+ src/FRP/Reactive/Fun.hs view
@@ -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)))])+            ]+        )
+ src/FRP/Reactive/Future.hs view
@@ -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")
+ src/FRP/Reactive/Improving.hs view
@@ -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
+ src/FRP/Reactive/Internal/Behavior.hs view
@@ -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
+ src/FRP/Reactive/Internal/Clock.hs view
@@ -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)
+ src/FRP/Reactive/Internal/Fun.hs view
@@ -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
+ src/FRP/Reactive/Internal/Future.hs view
@@ -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"+
+ src/FRP/Reactive/Internal/IVar.hs view
@@ -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
+ src/FRP/Reactive/Internal/Misc.hs view
@@ -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
+ src/FRP/Reactive/Internal/Reactive.hs view
@@ -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
+ src/FRP/Reactive/Internal/Serial.hs view
@@ -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)
+ src/FRP/Reactive/Internal/TVal.hs view
@@ -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
+ src/FRP/Reactive/Internal/Timing.hs view
@@ -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
+ src/FRP/Reactive/LegacyAdapters.hs view
@@ -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
+ src/FRP/Reactive/Num.hs view
@@ -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+
+ src/FRP/Reactive/PrimReactive.hs view
@@ -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..])
+ src/FRP/Reactive/Reactive.hs view
@@ -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!+            ]+        )
+ src/FRP/Reactive/SImproving.hs view
@@ -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.
+ src/FRP/Reactive/Sorted.hs view
@@ -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
+ src/FRP/Reactive/VectorSpace.hs view
@@ -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 *^)
+ src/Test/Reactive.hs view
@@ -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