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