**diff options**

author | RussellOConnor <> | 2011-09-10 21:41:20 (GMT) |
---|---|---|

committer | hdiff <hdiff@luite.com> | 2011-09-10 21:41:20 (GMT) |

commit | 0b3d060a98fcf00a42d53ec3b2d1abb3c49dc4dd (patch) | |

tree | 02250430eed69efeaa661b7a5e964b236bb08580 /src | |

parent | 1b032143b301a7fffe25c1b5ab82fb10827fa91c (diff) |

Diffstat (limited to 'src')

39 files changed, 926 insertions, 4932 deletions

diff --git a/src/Data/AddBounds.hs b/src/Data/AddBounds.hs deleted file mode 100755 index 77f0bae..0000000 --- a/src/Data/AddBounds.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : Data.AddBounds --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Add bounds to an ordered type ----------------------------------------------------------------------- - -module Data.AddBounds (AddBounds(..)) where - -import Control.Applicative (pure,(<$>)) - -import Data.Unamb (unamb) - -import Data.AffineSpace - --- 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 - - --- The definition above is too strict for some uses. Here's a parallel --- version. - - --- Alternatively, make a non-parallel definition here and use 'pmin' --- instead of 'min' where I want. - - --- General recipe for Ord methods: use unamb to try two strategies. The --- first one, "justB", only examines b. The second one first examines --- only examines a and then examines both. I take care that the two --- strategies handle disjoint inputs. I could instead let the second --- strategy handle the first one redundantly, being careful that they --- agree. - --- This instance is very like the one Richard Smith (lilac) constructed. --- It fixes a couple of small bugs and follows a style that helps me see --- that I'm covering all of the cases with the evaluation order I want. - -instance Ord a => Ord (AddBounds a) where - a <= b = justB b `unamb` (a <=* b) - where - justB MaxBound = True - justB _ = undefined - - MinBound <=* _ = True - _ <=* MinBound = False - NoBound u <=* NoBound v = u <= v - MaxBound <=* NoBound _ = False - _ <=* MaxBound = undefined - - a `min` b = justB b `unamb` (a `min'` b) - where - justB MinBound = MinBound - justB MaxBound = a - justB (NoBound _) = undefined - - MinBound `min'` _ = MinBound - MaxBound `min'` v = v - NoBound u `min'` NoBound v = NoBound (u `min` v) - _ `min'` MinBound = undefined - _ `min'` MaxBound = undefined - - a `max` b = justB b `unamb` (a `max'` b) - where - justB MaxBound = MaxBound - justB MinBound = a - justB (NoBound _) = undefined - - MaxBound `max'` _ = MaxBound - MinBound `max'` v = v - NoBound u `max'` NoBound v = NoBound (u `max` v) - _ `max'` MaxBound = undefined - _ `max'` MinBound = undefined - - --- instance Arbitrary a => Arbitrary (AddBounds a) where --- arbitrary = frequency [ (1 ,pure MinBound) --- , (10, NoBound <$> arbitrary) --- , (1 ,pure MaxBound) ] --- coarbitrary MinBound = variant 0 --- coarbitrary (NoBound a) = variant 1 . coarbitrary a --- coarbitrary MaxBound = variant 2 - -instance Arbitrary a => Arbitrary (AddBounds a) where - arbitrary = frequency [ (1 ,pure MinBound) - , (10, NoBound <$> arbitrary) - , (1 ,pure MaxBound) ] - -instance CoArbitrary a => CoArbitrary (AddBounds a) where - coarbitrary MinBound = variant (0::Int) - coarbitrary (NoBound a) = variant (1::Int) . coarbitrary a - coarbitrary MaxBound = variant (2::Int) - -instance (EqProp a, Eq a) => EqProp (AddBounds a) where - NoBound a =-= NoBound b = a =-= b - u =-= v = u `eq` v - - --- Hm. I'm dissatisfied with this next instance. I'd like to tweak my --- type definitions to eliminate these partial definitions. - -instance AffineSpace t => AffineSpace (AddBounds t) where - type Diff (AddBounds t) = Diff t - NoBound u .-. NoBound v = u .-. v - -- I don't know what to do here - _ .-. _ = error "(.-.) on AddBounds: only defined on NoBound args" - NoBound u .+^ v = NoBound (u .+^ v) - _ .+^ _ = error "(.+^) on AddBounds: only defined on NoBound args" diff --git a/src/Data/Fun.hs b/src/Data/Fun.hs new file mode 100644 index 0000000..13df3a5 --- /dev/null +++ b/src/Data/Fun.hs @@ -0,0 +1,62 @@ +---------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 0000000..da86a49 --- /dev/null +++ b/src/Data/Future.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE RecursiveDo #-} +-- For ghc-6.6 compatibility +-- {-# OPTIONS_GHC -fglasgow-exts #-} + +---------------------------------------------------------------------- +-- | +-- Module : Data.Future +-- Copyright : (c) Conal Elliott 2007 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- A /future value/ is a value that will become knowable only later. This +-- module gives a way to manipulate them functionally. For instance, +-- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable. +-- See <http://en.wikipedia.org/wiki/Futures_and_promises>. +-- +-- Primitive futures can be things like /the value of the next key you +-- press/, or /the value of LambdaPix stock at noon next Monday/. +-- +-- Composition is via standard type classes: 'Functor', 'Applicative', +-- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of +-- these classes: +-- +-- * Monoid: 'mempty' is a future that never becomes knowable. +-- @a `mappend` b@ is whichever of @a@ and @b@ is knowable first. +-- +-- * 'Functor': apply a function to a future. The result is knowable when +-- the given future is knowable. +-- +-- * 'Applicative': 'pure' gives value knowable since the beginning of +-- time. '(\<*\>)' applies a future function to a future argument. +-- Result available when /both/ are available, i.e., it becomes knowable +-- when the later of the two futures becomes knowable. +-- +-- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@ cascades +-- futures. 'join' resolves a future future into a future. +-- +-- The current implementation is nondeterministic in 'mappend' for futures +-- that become knowable at the same time or nearly the same time. I +-- want to make a deterministic implementation. +-- +-- See "Data.SFuture" for a simple denotational semantics of futures. The +-- current implementation /does not/ quite implement this target semantics +-- for 'mappend' when futures are available simultaneously or nearly +-- simultaneously. I'm still noodling how to implement that semantics. +---------------------------------------------------------------------- + +module Data.Future + ( Future(..), force, newFuture + , future + , runFuture + ) where + +import Control.Concurrent +import Data.Monoid (Monoid(..)) +import Control.Applicative +import Control.Monad (join,forever) +import System.IO.Unsafe +-- import Foreign (unsafePerformIO) + +-- TypeCompose +import Control.Instances () -- IO monoid + +-- About determinacy: for @f1 `mappend` f2@, we might get @f2@ instead of +-- @f1@ even if they're available simultaneously. It's even possible to +-- get the later of the two if they're nearly simultaneous. +-- +-- What will it take to get deterministic semantics for @f1 `mappend` f2@? +-- Idea: make an "event occurrence" type, which is a future with a time +-- and a value. (The time is useful for snapshotting continuous +-- behaviors.) When one occurrence happens with a time @t@, query whether +-- the other one occurs by the same time. What does it take to support +-- this query operation? +-- +-- Another idea: speculative execution. When one event occurs, continue +-- to compute consequences. If it turns out that an earlier occurrence +-- arrives later, do some kind of 'retry'. + +-- The implementation is very like IVars. Each future contains an MVar +-- reader. 'force' blocks until the MVar is written. + +-- | Value available in the future. +data Future a = + -- | Future that may arrive. The 'IO' blocks until available. No side-effect. + Future (IO a) + -- | Future that never arrives. + | Never + +-- Why not simply use @a@ (plain-old lazy value) in place of @IO a@ in +-- 'Future'? Several of the definitions below get simpler, and many +-- examples work. See NewFuture.hs. But sometimes that implementation +-- mysteriously crashes or just doesn't update. Odd. + +-- | Access a future value. Blocks until available. +force :: Future a -> IO a +force (Future io) = io +force Never = hang + +-- | Block forever +hang :: IO a +hang = do -- putStrLn "warning: blocking forever." + -- Any never-terminating computation goes here + -- This one can yield an exception "thread blocked indefinitely" + -- newEmptyMVar >>= takeMVar + -- sjanssen suggests this alternative: + forever $ threadDelay maxBound + -- forever's return type is (), though it could be fully + -- polymorphic. Until it's fixed, I need the following line. + return undefined + +-- | Make a 'Future' and a way to fill it. The filler should be invoked +-- only once. +newFuture :: IO (Future a, a -> IO ()) +newFuture = do v <- newEmptyMVar + return (Future (readMVar v), putMVar v) + +-- | Make a 'Future', given a way to compute a value. +future :: IO a -> Future a +future mka = unsafePerformIO $ + do (fut,sink) <- newFuture + forkIO $ mka >>= sink + return fut +{-# NOINLINE future #-} + +instance Functor Future where + fmap f (Future get) = future (fmap f get) + fmap _ Never = Never + +instance Applicative Future where + pure a = Future (pure a) + Future getf <*> Future getx = future (getf <*> getx) + _ <*> _ = Never + +-- Note Applicative's pure uses 'Future' as an optimization over +-- 'future'. No thread or MVar. + +instance Monad Future where + return = pure + Future geta >>= h = future (geta >>= force . h) + Never >>= _ = Never + +instance Monoid (Future a) where + mempty = Never + mappend = race + +-- | Race to extract a value. +race :: Future a -> Future a -> Future a +Never `race` b = b +a `race` Never = a +a `race` b = unsafePerformIO $ + do (c,sink) <- newFuture + lock <- newEmptyMVar -- to avoid double-kill + let run fut tid = forkIO $ do x <- force fut + putMVar lock () + killThread tid + sink x + mdo ta <- run a tb + tb <- run b ta + return () + return c +{-# NOINLINE race #-} + +-- TODO: make race deterministic, using explicit times. Figure out how +-- one thread can inquire whether the other whether it is available by a +-- given time, and if so, what time. + +-- | Run an 'IO'-action-valued 'Future'. +runFuture :: Future (IO ()) -> IO () +runFuture = join . force diff --git a/src/Data/Max.hs b/src/Data/Max.hs deleted file mode 100755 index 482776d..0000000 --- a/src/Data/Max.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall #-} ----------------------------------------------------------------------- --- | --- Module : Data.Max --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Max monoid ----------------------------------------------------------------------- - -module Data.Max (Max(..)) where - - -import Data.Monoid (Monoid(..)) - -import Test.QuickCheck (Arbitrary, CoArbitrary) -import Test.QuickCheck.Checkers (EqProp) - - --- | Ordered monoid under 'max'. -newtype Max a = Max { getMax :: a } - deriving (Eq, Ord, Bounded, Read, Show, EqProp, Arbitrary, CoArbitrary) - -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 deleted file mode 100755 index ed7e61b..0000000 --- a/src/Data/Min.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall #-} ----------------------------------------------------------------------- --- | --- Module : Data.Min --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Min monoid ----------------------------------------------------------------------- - -module Data.Min (Min(..)) where - -import Data.Monoid (Monoid(..)) - -import Test.QuickCheck (Arbitrary) -import Test.QuickCheck.Checkers (EqProp) - --- | 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 deleted file mode 100755 index aa34bb4..0000000 --- a/src/Data/PairMonad.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ----------------------------------------------------------------------- --- | --- Module : Data.PairMonad --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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 new file mode 100644 index 0000000..6a2e016 --- /dev/null +++ b/src/Data/Reactive.hs @@ -0,0 +1,498 @@ +-- {-# 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 new file mode 100644 index 0000000..ba4bed9 --- /dev/null +++ b/src/Data/SFuture.hs @@ -0,0 +1,195 @@ +-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall -fno-warn-orphans #-} +-- For ghc-6.6 compatibility +{-# OPTIONS_GHC -fglasgow-exts #-} + +---------------------------------------------------------------------- +-- | +-- Module : Data.SFuture +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- A sort of semantic prototype for functional /futures/, roughly as +-- described at <http://en.wikipedia.org/wiki/Futures_and_promises>. +-- +-- A /future/ is a value that will become knowable only later. This +-- module gives a way to manipulate them functionally. For instance, +-- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable. +-- +-- Primitive futures can be things like /the value of the next key you +-- press/, or /the value of LambdaPix stock at noon next Monday/. +-- +-- Composition is via standard type classes: 'Ord', 'Functor', +-- 'Applicative', 'Monad', and 'Monoid'. Some comments on the 'Future' +-- instances of these classes: +-- +-- * 'Ord': @a `min` b@ is whichever of @a@ and @b@ is knowable first. @a +-- `max` b@ is whichever of @a@ and @b@ is knowable last. +-- +-- * Monoid: 'mempty' is a future that never becomes knowable. 'mappend' +-- is the same as 'min'. +-- +-- * 'Functor': apply a function to a future. The result is knowable when +-- the given future is knowable. +-- +-- * 'Applicative': 'pure' gives value knowable since the beginning of +-- time. '(\<*\>)' applies a future function to a future argument. +-- Result available when /both/ are available, i.e., it becomes knowable +-- when the later of the two futures becomes knowable. +-- +-- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@ +-- cascades futures. 'join' resolves a future future value into a +-- future value. +-- +-- Futures are parametric over /time/ as well as /value/ types. The time +-- parameter can be any ordered type. +-- +-- Please keep in mind that this module specifies the interface and +-- semantics, rather than a useful implementation. See "Data.Future" for +-- an implementation that nearly implements the semantics described here. +-- +-- On second thought, I'm experimenting with using this module in an +-- usable implementation of events. See Data.MEvent. +---------------------------------------------------------------------- + +module Data.SFuture + ( + -- * Time & futures + Time, Future(..), futTime, futVal, sequenceF + -- * To go elsewhere + , Max(..), Min(..), AddBounds(..) + ) where + +import Data.Monoid (Monoid(..)) +import Control.Applicative (Applicative(..)) +import Data.Function (on) + + +{---------------------------------------------------------- + Time and futures +----------------------------------------------------------} + +-- | Time of some event occurrence, which can be any @Ord@ type. In an +-- actual implementation, we would not usually have access to the time +-- value until (slightly after) that time. Extracting the actual time +-- would block until the time is known. The added bounds represent +-- -Infinity and +Infinity. Pure values have time minBound (-Infinity), +-- while eternally unknowable values (non-occurring events) have time +-- maxBound (+Infinity). +type Time t = Max (AddBounds t) + +-- | A future value of type @a@ with time type @t@. Semantically, just a +-- time\/value pair, but those values would not be available until +-- 'force'd, which could block. +newtype Future t a = Future { unFuture :: (Time t, a) } + deriving (Functor, Applicative, Monad, Show) + +-- The 'Applicative' instance relies on the 'Monoid' instance of 'Max'. + +-- | A future's time +futTime :: Future t a -> Time t +futTime = fst . unFuture + +-- | A future's value +futVal :: Future t a -> a +futVal = snd . unFuture + + +-- -- The Monoid instance picks the earlier future +-- instance Ord t => Monoid (Future t a) where +-- mempty = Future (maxBound, error "it'll never happen, buddy") +-- fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) = +-- if t <= t' then fut else fut' + +-- or: + + +instance Eq (Future t a) where + (==) = error "sorry, no (==) for futures" + +instance Ord t => Ord (Future t a) where + (<=) = (<=) `on` futTime + -- We could leave 'min' to the default in terms of '(<=)', but the + -- following can yield partial time info, as much as allowed by the time + -- parameter type @t@ and its 'min'. + Future (s,a) `min` Future (t,b) = + Future (s `min` t, if s <= t then a else b) + +-- For some choices of @t@, there may be an efficient combination of 'min' +-- and '(<=)'. In particular, 'Improving' has 'minI'. + +instance Ord t => Monoid (Future t a) where + mempty = Future (maxBound, error "it'll never happen, buddy") + mappend = min + +-- 'sequenceF' is like 'sequenceA' from "Data.Traversable". However, +-- the @Traversable@ class assumes @Foldable@, which I'm not confident +-- how to implement usefully. (I could of course just strip off the +-- 'Future' constructor and the time. Why is Foldable required? + +-- | Make a future container into a container of futures. +sequenceF :: Functor f => Future t (f a) -> f (Future t a) +sequenceF (Future (tt, f)) = fmap (Future . ((,) tt)) f + + + +{---------------------------------------------------------- + To go elsewhere +----------------------------------------------------------} + +-- For Data.Monoid: + +-- | Ordered monoid under 'max'. +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = Max minBound + Max a `mappend` Max b = Max (a `max` b) + +-- | Ordered monoid under 'min'. +newtype Min a = Min { getMin :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = Min maxBound + Min a `mappend` Min b = Min (a `min` b) + +-- I have a niggling uncertainty about the 'Ord' & 'Bounded' instances for +-- @Min a@? Is there a reason flip the @a@ ordering instead of preserving +-- it? + +-- For Control.Monad.Instances + +-- Equivalent to the Monad Writer instance. +-- import Data.Monoid +instance Monoid o => Monad ((,) o) where + return = pure + (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a + +-- Alternatively, +-- m >>= f = join (fmap f m) +-- where +-- join ((o, (o',a))) = (o `mappend` o', a) +-- Or even, +-- (o,a) >>= f = (o,id) <*> f a +-- +-- I prefer the join version, because it's the standard (>>=)-via-join, +-- plus a very simple definition for join. Too bad join isn't a method of +-- Monad, with (>>=) and join defined in terms of each other. Why isn't +-- it? Probably because Monad isn't derived from Functor. Was that an +-- oversight? + +-- Where to put this definition? Prelude? + +-- | Wrap a type into one having new least and greatest elements, +-- preserving the existing ordering. +data AddBounds a = MinBound | NoBound a | MaxBound + deriving (Eq, Ord, Read, Show) + +instance Bounded (AddBounds a) where + minBound = MinBound + maxBound = MaxBound diff --git a/src/Examples.hs b/src/Examples.hs deleted file mode 100755 index 08497e5..0000000 --- a/src/Examples.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# 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 deleted file mode 100755 index 17c185e..0000000 --- a/src/FRP/Reactive.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# OPTIONS -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- A library for programming with functional reactive behaviors. ----------------------------------------------------------------------- - -module FRP.Reactive - ( - -- * Events - TimeT, ITime - , EventG, Event - , accumE - , withTimeE, withTimeE_ - , zipE, scanlE, monoidE - , mealy, mealy_, countE, countE_, diffE - , withPrevE, withPrevEWith - , eitherE - , justE, filterE - -- ** More esoteric - , listE, atTimes, atTime, once - , firstRestE, firstE, restE, snapRemainderE - , withRestE, untilE - , splitE, switchE - -- ** Useful with events. - , joinMaybes, filterMP - -- * Behaviors - , BehaviorG, Behavior, Behaviour - , time - , stepper, switcher --, select - , snapshotWith, snapshot, snapshot_, whenE - , 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_,whenE,flipFlop,integral) -import FRP.Reactive.Behavior -import FRP.Reactive.VectorSpace () -import FRP.Reactive.Num () diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs deleted file mode 100755 index f4ceecd..0000000 --- a/src/FRP/Reactive/Behavior.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, TypeOperators - , StandaloneDeriving, GeneralizedNewtypeDeriving - , TypeSynonymInstances, UndecidableInstances - #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Behavior --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Reactive behaviors (continuous time) ----------------------------------------------------------------------- - -module FRP.Reactive.Behavior - ( - BehaviorG, Behavior, Behaviour - , time - , stepper, switcher --, select - , snapshotWith, snapshot, snapshot_, whenE - , accumB, scanlB, monoidB, maybeB, flipFlop, countB - , sumB, integral - ) where - -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative,(<$>),pure) --- import Control.Monad (join) - -import Control.Comonad - -import Control.Compose ((:.)(..),unO) - -import Data.VectorSpace -import Data.AffineSpace - -import qualified FRP.Reactive.Reactive as R -import FRP.Reactive.Reactive - ( ImpBounds, TimeT, EventG, ReactiveG - , withTimeE,onceRestE,diffE,joinMaybes,result) -import FRP.Reactive.Fun --- import FRP.Reactive.Improving -import FRP.Reactive.Internal.Behavior - --- type EventI t = EventG (Improving t) --- type ReactiveI t = ReactiveG (Improving t) --- type BehaviorI t = BehaviorG (Improving t) t - -type EventI t = EventG (ImpBounds t) -type ReactiveI t = ReactiveG (ImpBounds t) -type BehaviorI t = BehaviorG (ImpBounds t) t - --- | Time-specialized behaviors. --- Note: The signatures of all of the behavior functions can be generalized. Is --- the interface generality worth the complexity? -type Behavior = BehaviorI TimeT - --- Synonym for 'Behavior' -type Behaviour = Behavior - - --- | The identity generalized behavior. Has value @t@ at time @t@. --- --- > time :: Behavior TimeT -time :: (Ord t) => BehaviorI t t -time = beh (pure (fun id)) - --- Turn a reactive value into a discretly changing behavior. -rToB :: ReactiveI t a -> BehaviorI t 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 :: a -> EventI t a -> BehaviorI t a -stepper = (result.result) 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 -switcher :: (Ord tr, Bounded tr) => - BehaviorG tr tf a - -> EventG tr (BehaviorG tr tf a) - -> BehaviorG tr tf 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. Take careful note of the order of --- arguments and results. --- --- > snapshotWith :: (a -> b -> c) -> Behavior b -> Event a -> Event c -snapshotWith :: (Ord t) => - (a -> b -> c) - -> BehaviorI t b -> EventI t a -> EventI t c -snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e) - where - f ((a,t),tfun) = h a (tfun `apply` t) - - --- 'snapshotWith' is where tr meets tf. withTimeE is specialized from --- withTimeGE, converting the ITime into a TimeT. This specialization --- interferes with the generality of several functions in this module, --- which are therefore now still using 'Behavior' instead of 'BehaviorG'. --- Figure out how to get generality. - - --- | Snapshot a behavior whenever an event occurs. See also --- 'snapshotWith'. Take careful note of the order of arguments and --- results. --- --- > snapshot :: Behavior b -> Event a -> Event (a,b) -snapshot :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t (a,b) -snapshot = snapshotWith (,) - --- TODO: tweak withTimeE so that 'snapshotWith' and 'snapshot' can have --- more general types. The problem is that withTimeE gives a friendlier --- kind of time, namely known and finite. Necessary? - --- Alternative implementations: --- snapshotWith c e b = uncurry c <$> snapshot e b --- snapshotWith c = (result.result.fmap) (uncurry c) snapshot - --- | Like 'snapshot' but discarding event data (often @a@ is '()'). --- --- > snapshot_ :: Behavior b -> Event a -> Event b -snapshot_ :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t b -snapshot_ = snapshotWith (flip const) - --- Alternative implementations --- e `snapshot_` src = snd <$> (e `snapshot` src) --- snapshot_ = (result.result.fmap) snd snapshot - --- | Filter an event according to whether a reactive boolean is true. --- --- > whenE :: Behavior Bool -> Event a -> Event a -whenE :: (Ord t) => BehaviorI t Bool -> EventI t a -> EventI t a -b `whenE` e = joinMaybes (h <$> (b `snapshot` e)) - where - h (a,True) = Just a - h (_,False) = Nothing - --- TODO: Same comment about generality as with snapshot - --- | Behavior from an initial value and an updater event. See also --- 'accumE'. --- --- > accumB :: a -> Event (a -> a) -> Behavior a -accumB :: a -> EventI t (a -> a) -> BehaviorI t a -accumB = (result.result) rToB R.accumR - --- -- | Like 'scanl' for behaviors. See also 'scanlE'. --- scanlB :: (a -> b -> a) -> a -> Event b -> Behavior a --- scanlB = (result.result.result) rToB R.scanlR - --- -- | Accumulate values from a monoid-valued event. Specialization of --- -- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. --- monoidB :: Monoid a => Event a -> Behavior a --- monoidB = result rToB R.monoidR - - ----- The next versions are more continuous: - --- type RF a = Reactive (Fun TimeT a) - --- scanlB :: forall a c. (Behavior a -> c -> Behavior a) -> Behavior a --- -> Event c -> Behavior a --- scanlB f b0 e = beh (scanlRF f' (unb b0) e) --- where --- f' :: RF a -> c -> RF a --- f' r c = unb (f (beh r) c) - --- scanlRF :: (RF a -> c -> RF a) -> RF a -> Event c -> RF a --- scanlRF h rf0 e = join (R.scanlR h rf0 e) - --- monoidB :: Monoid a => Event (Behavior a) -> Behavior a --- monoidB = scanlB mappend mempty - --- -- I doubt the above definitions work well. They accumulate reactives without --- -- aging them. See 'accumE'. - - --- | Like 'scanl' for behaviors. See also 'scanlE'. --- --- > scanlB :: forall a. (Behavior a -> Behavior a -> Behavior a) -> Behavior a --- > -> Event (Behavior a) -> Behavior a - --- TODO: generalize scanlB's type - -scanlB :: forall a b tr tf. (Ord tr, Bounded tr) => - (b -> BehaviorG tr tf a -> BehaviorG tr tf a) - -> BehaviorG tr tf a - -> EventG tr b -> BehaviorG tr tf a -scanlB plus zero = h - where - h :: EventG tr b -> BehaviorG tr tf a - h e = zero `switcher` (g <$> onceRestE e) - g :: (b, EventG tr b) -> BehaviorG tr tf a - g (b, e') = b `plus` h e' - - --- | Accumulate values from a monoid-valued event. Specialization of --- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. --- --- > monoidB :: Monoid a => Event (Behavior a) -> Behavior a -monoidB :: (Ord tr, Bounded tr, Monoid a) => EventG tr (BehaviorG tr tf a) - -> BehaviorG tr tf a -monoidB = scanlB mappend mempty - --- | Like 'sum' for behaviors. --- --- > sumB :: AdditiveGroup a => Event a -> Behavior a -sumB :: (Ord t, AdditiveGroup a) => EventI t a -> BehaviorI t a -sumB = result rToB R.sumR - --- | Start out blank ('Nothing'), latching onto each new @a@, and blanking --- on each @b@. If you just want to latch and not blank, then use --- 'mempty' for the second event. --- --- > maybeB :: Event a -> Event b -> Behavior (Maybe a) -maybeB :: (Ord t) => - EventI t a -> EventI t b -> BehaviorI t (Maybe a) -maybeB = (result.result) rToB R.maybeR - --- | Flip-flopping behavior. Turns true whenever first event occurs and --- false whenever the second event occurs. --- --- > flipFlop :: Event a -> Event b -> Behavior Bool -flipFlop :: (Ord t) => EventI t a -> EventI t b -> BehaviorI t Bool -flipFlop = (result.result) rToB R.flipFlop - --- | Count occurrences of an event. See also 'countE'. --- --- > countB :: Num n => Event a -> Behavior n -countB :: (Ord t, Num n) => EventI t a -> BehaviorI t n -countB = result rToB R.countR - --- | Euler integral. --- --- > integral :: (VectorSpace v, Scalar v ~ TimeT) => --- > Event () -> Behavior v -> Behavior v -integral :: (VectorSpace v, AffineSpace t, Scalar v ~ Diff t, Ord t) => - EventI t a -> BehaviorI t v -> BehaviorI t v -integral t b = sumB (snapshotWith (*^) b (diffE (time `snapshot_` t))) - --- TODO: This integral definition is piecewise-constant. Change to piecewise-linear. - - --- 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. --- Chuan-kai Lin has come up with a new lazier R.snapshotWith, but it --- leaks when the reactive value changes in between event occurrences. - - ----- Comonadic stuff - --- Orphan. Move elsewhere - -instance (Functor g, Functor f, Copointed g, Copointed f) - => Copointed (g :. f) where - extract = extract . extract . unO - --- instance (Comonad g, Comonad f) => Comonad (g :. f) where --- duplicate = inO (fmap duplicate . duplicate) - - --- WORKING HERE - --- The plan for duplicate: --- --- (g :. f) a -> g (f a) -> g (f (f a)) -> g (g (f (f a))) --- -> g (f (g (f a))) -> (g :. f) (g (f a)) --- -> (g :. f) ((g :. f) a) -> - --- But we'll have to do that middle twiddle, which I couldn't do for --- behaviors to get a Monad either. Is there another way? - - --- instance Comonad (g :. f) where --- duplicate - -deriving instance (Monoid tr, Monoid tf) => Copointed (BehaviorG tr tf) - --- ITime and TimeT are not currently monoids. They can be when I wrap --- them in the Sum monoid constructor, in which mempty = 0 and mappend = --- (+). This monoid change moves us from absolute to relative time. What --- do I do for never-occuring futures and terminating events? - --- - --- instance (Ord t, Monoid t, Monoid (Improving t)) => Comonad (BehaviorI t) where --- duplicate = duplicateB - --- duplicateB :: forall t a. --- (Ord t, Monoid t, Monoid (Improving t)) => --- BehaviorI t -> BehaviorI t (BehaviorI t a) where --- duplicate b@(_ `Stepper`) = bb0 `switcher` --- where --- f0 `R.Stepper` e = unb b --- bb0 = beh (pure (fun (\ t -> undefined))) - --- f0 :: T a - --- e :: E (T a) - --- duplicate f0 :: T (T a) - - --- b :: B a - --- unb b :: R (T a) - - - --- dup b :: B (B a) - - --- TODO: generalize to BehaviorG --- TODO: something about Monoid (Improving t) - --- Standard instances for applicative functors - --- #define APPLICATIVE Behavior --- #include "Num-inc.hs" diff --git a/src/FRP/Reactive/Fun.hs b/src/FRP/Reactive/Fun.hs deleted file mode 100755 index 14076ee..0000000 --- a/src/FRP/Reactive/Fun.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Fun --- Copyright : (c) Conal Elliott 2007 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Functions, with constant functions optimized, with instances for many --- standard classes. ----------------------------------------------------------------------- - -module FRP.Reactive.Fun (Fun, fun, apply, batch) where - -import Prelude hiding - ( zip, zipWith -#if __GLASGOW_HASKELL__ >= 609 - , (.), id -#endif - ) -#if __GLASGOW_HASKELL__ >= 609 -import Control.Category -#endif - - -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative(..),liftA) -import Control.Arrow -#if __GLASGOW_HASKELL__ < 610 - hiding (pure) -#endif -import Text.Show.Functions () - -import Control.Comonad - -import Data.Zip (Zip(..)) - -import Test.QuickCheck -import Test.QuickCheck.Checkers -import Test.QuickCheck.Classes - -import FRP.Reactive.Internal.Fun - - --- TODO: write RULE for fun . const = K -fun :: (t -> a) -> Fun t a -fun = Fun - -instance (CoArbitrary a,Arbitrary b) => Arbitrary (Fun a b) where - arbitrary = oneof [liftA K arbitrary, liftA Fun arbitrary] - -instance (Arbitrary a, CoArbitrary b) => CoArbitrary (Fun a b) where - coarbitrary (K a) = variant (0 :: Int) . coarbitrary a - coarbitrary (Fun x) = variant (1 :: Int) . 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) -- == Fun (fmap f g) - -instance Zip (Fun t) where - K x `zip` K y = K (x,y) - cf `zip` cx = Fun (apply cf `zip` apply cx) - -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 - -instance Pointed (Fun t) where - point = K - -instance Monoid t => Copointed (Fun t) where - extract = extract . apply - -instance Monoid t => Comonad (Fun t) where - duplicate (K a) = K (K a) - duplicate (Fun f) = Fun (Fun . duplicate f) - - - ----------------------------------- - -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 deleted file mode 100755 index cc01bc6..0000000 --- a/src/FRP/Reactive/Future.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Future --- Copyright : (c) Conal Elliott 2007-2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- A simple formulation of functional /futures/, roughly as --- described at <http://en.wikipedia.org/wiki/Futures_and_promises>. --- --- A /future/ is a value with an associated time of /arrival/. Typically, --- neither the time nor the value can be known until the arrival time. --- --- Primitive futures can be things like /the value of the next key you --- press/, or /the value of LambdaPix stock at noon next Monday/. --- --- Composition is via standard type classes: 'Functor', 'Applicative', --- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of --- these classes: --- --- * Monoid: 'mempty' is a future that never arrives (infinite time and --- undefined value), and @a `mappend` b@ is the earlier of @a@ and @b@, --- preferring @a@ when simultaneous. --- --- * 'Functor': apply a function to a future argument. The (future) --- result arrives simultaneously with the argument. --- --- * 'Applicative': 'pure' gives value arriving negative infinity. --- '(\<*\>)' applies a future function to a future argument, yielding a --- future result that arrives once /both/ function and argument have --- arrived (coinciding with the later of the two times). --- --- * 'Monad': 'return' is the same as 'pure' (as usual). @(>>=)@ cascades --- futures. 'join' resolves a future future value into a future value. --- --- Futures are parametric over /time/ as well as /value/ types. The time --- parameter can be any ordered type and is particularly useful with time --- types that have rich partial information structure, such as /improving --- values/. ----------------------------------------------------------------------- - -module FRP.Reactive.Future - ( - -- * Time & futures - Time, ftime - , FutureG(..), isNeverF, 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 - --- FutureG representation in Internal.Future - -instance (Bounded t, Eq t, EqProp t, EqProp a) => EqProp (FutureG t a) where - u =-= v | isNeverF u && isNeverF v = property True - Future a =-= Future b = a =-= b - --- I'd rather say: --- --- instance (Bounded t, EqProp t, EqProp a) => EqProp (FutureG t a) where --- Future a =-= Future b = --- (fst a =-= maxBound && fst b =-= maxBound) .|. a =-= b --- --- However, I don't know how to define disjunction on QuickCheck properties. - --- | A future's time -futTime :: FutureG t a -> Time t -futTime = fst . unFuture - --- | 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)) - --- withTimeF = inFuture duplicate (with Comonad) - --- TODO: Eliminate this Monoid instance. Derive Monoid along with all the --- other classes. And don't use mempty and mappend for the operations --- below. For one thing, the current instance makes Future a monoid but --- unFuture not be a monoid morphism. - -instance (Ord t, Bounded t) => Monoid (FutureG t a) where - mempty = Future (maxBound, error "Future mempty: it'll never happen, buddy") - -- Pick the earlier future. - Future (s,a) `mappend` Future (t,b) = - Future (s `min` t, if s <= t then a else b) - --- 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'. - - --- -- A future known never to happen (by construction), i.e., infinite time. --- isNever :: FutureG t a -> Bool --- isNever = isMaxBound . futTime --- where --- isMaxBound (Max MaxBound) = True --- isMaxBound _ = False --- --- This function is an abstraction leak. Don't export it to library --- users. - - - -{---------------------------------------------------------- - Tests -----------------------------------------------------------} - --- Represents times at a given instant. -newtype TimeInfo t = TimeInfo (Maybe t) - deriving EqProp - -instance Bounded t => Bounded (TimeInfo t) where - minBound = TimeInfo (Just minBound) - maxBound = TimeInfo Nothing - - --- A time at a given instant can be some unknown time in the future -unknownTimeInFuture :: TimeInfo a -unknownTimeInFuture = TimeInfo Nothing - --- 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 :: BoundedT -> T -> Property - laziness t a = (uf `mappend` uf) `mappend` kf =-= kf - where - uf = unknownFuture - kf = knownFuture - knownFuture = future (knownTimeInPast t) a - unknownFuture = future unknownTimeInFuture (error "cannot retrieve value at unknown time at the future") - - --- Move to checkers -type BoundedT = Int diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs deleted file mode 100755 index 41b13a8..0000000 --- a/src/FRP/Reactive/Improving.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Improving --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Improving values -- efficient version ----------------------------------------------------------------------- - -module FRP.Reactive.Improving - ( - Improving(..), exactly, before, after, minI, maxI - , batch - ) where - - -import Data.Function (on) -import Text.Show.Functions () -import Control.Applicative (pure,(<$>),liftA2) - -import Data.Unamb (unamb,parCommute,pmin,pmax) - -import Test.QuickCheck --- import Test.QuickCheck.Instances -import Test.QuickCheck.Checkers -import Test.QuickCheck.Classes -import Test.QuickCheck.Instances.Num - - -{---------------------------------------------------------- - Improving values -----------------------------------------------------------} - --- | An improving value. -data Improving a = Imp { exact :: a, compareI :: a -> Ordering } - -- deriving Show - -instance Show a => Show (Improving a) where - show = ("Imp "++) . show . exact - --- | A known improving value (which doesn't really improve) -exactly :: Ord a => a -> Improving a -exactly a = Imp a (compare a) - --- | A value known to be @< x@. -before :: Ord a => a -> Improving a -before x = Imp undefined comp - where - comp y | x <= y = LT - | otherwise = error "before: comparing before" - --- | A value known to be @> x@. -after :: Ord a => a -> Improving a -after x = Imp undefined comp - where - comp y | x >= y = GT - | otherwise = error "after: comparing after" - - -instance Eq a => Eq (Improving a) where - -- (==) = (==) `on` exact - -- This version can prove inequality without having to know both values - -- exactly. - (==) = parCommute (\ u v -> u `compareI` exact v == EQ) - --- TODO: experiment with these two versions of (==). The 'parCommute' one --- can return 'False' sooner than the simpler def, but I doubt it'll --- return 'True' any sooner. - -instance Ord a => Ord (Improving a) where - min = (result.result) fst minI - (<=) = (result.result) snd minI - max = (result.result) fst maxI - --- | 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) - wComp = liftA2 pmin uComp vComp - --- -- (u `min` v) `compare` t: Try comparing according to whether u <= v, --- -- or go with either answer if they agree, e.g., if both say GT. --- -- And say GT if either comp says LT. --- wComp t = (uCt `asAgree` LT `unamb` vCt `asAgree` LT) -- LT cases --- `unamb` (uCt `min` vCt) -- EQ and GT case --- where --- uCt = uComp t --- vCt = vComp t - --- | Efficient combination of 'max' and '(>=)' -maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool) -~(Imp u uComp) `maxI` ~(Imp v vComp) = (Imp uMaxV wComp, uGeqV) - 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) - wComp = liftA2 pmax uComp vComp - --- -- (u `max` v) `compare` t: Try comparing according to whether u >= v, --- -- or go with either answer if they agree, e.g., if both say LT. --- -- And say LT if either comp says GT. --- wComp t = (uCt `asAgree` GT `unamb` vCt `asAgree` GT) -- GT cases --- `unamb` (uCt `max` vCt) -- EQ and LT case --- where --- uCt = uComp t --- vCt = vComp t - --- TODO: reconsider these wComp tests and look for a smaller set. - --- TODO: factor commonality out of 'minI' and 'maxI' or combine into --- a single function. - --- TODO: Are the lazy patterns at all helpful? - - --- Experimental 'Bounded' instance. I'm curious about it as an --- alternative to using 'AddBounds'. However, it seems to lose the --- advantage of a knowably infinite value, which I use in a lot of --- optimization, including filter/join. - --- instance Bounded (Improving a) where --- minBound = error "minBound not defined on Improving" --- maxBound = Imp (error "exact maxBound") --- (const GT) - -instance (Ord a, Bounded a) => Bounded (Improving a) where - minBound = exactly minBound - maxBound = exactly maxBound - --- Hack: use 0 as lower bound --- No, this one won't work, because I'll need to extract the exact value --- in order to compare with maxBound - --- instance (Ord a, Num a) => Bounded (Improving a) where --- minBound = exactly 0 --- maxBound = -- exactly maxBound --- Imp (error "Improving maxBound evaluated") --- (const GT) - - --- TODO: consider 'undefined' instead 'error', for 'unamb'. However, we --- lose valuable information if the 'undefined' gets forced with no --- 'unamb' to handle it. Maybe make 'unamb' handle more exceptions. - - ----- - - --- Modify the result of a function. See --- <http://conal.net/blog/semantic-editor-combinators>. -result :: (b -> b') -> ((a -> b) -> (a -> b')) -result = (.) - - ----- - --- For now, generate exactly-knowable values. --- TODO: generate trickier improving values. - -instance (Ord a, Arbitrary a) => Arbitrary (Improving a) where - arbitrary = exactly <$> arbitrary - -instance (CoArbitrary a) => CoArbitrary (Improving a) where - coarbitrary = coarbitrary . exact - -instance Model (Improving a) a where model = exact - -instance EqProp a => EqProp (Improving a) where - (=-=) = (=-=) `on` exact - --- TODO: revisit (=-=). Maybe it doesn't have to test for full equality. - -genGE :: (Arbitrary a, Num a) => Improving a -> Gen (Improving a) -genGE i = add i <$> oneof [pure 0, positive] - --- I didn't use nonNegative in genGE, because I want zero pretty often, --- especially for the antiSymmetric law. - -add :: Num a => Improving a -> a -> Improving a -add (Imp x comp) dx = Imp (x + dx) (comp . subtract dx) - -batch :: TestBatch -batch = ( "Reactive.Improving" - , concatMap unbatch - [ ordI, semanticOrdI, partial ] - ) - where - ordI = ord (genGE :: Improving NumT -> Gen (Improving NumT)) - semanticOrdI = semanticOrd (undefined :: Improving NumT) - -partial :: TestBatch -partial = ( "Partial" - , [ ("min after" , property (minAL :: NumT -> NumT -> Bool)) - , ("max before", property (maxAL :: NumT -> NumT -> Bool)) - ] - ) - -minAL :: Ord a => a -> a -> Bool -minAL x y = after x `min` after y >= exactly (x `min` y) - -maxAL :: Ord a => a -> a -> Bool -maxAL x y = before x `max` before y <= exactly (x `max` y) - - --- Now I realize that the Ord laws are implied by semantic Ord property, --- assuming that the model satisfies the Ord laws. - diff --git a/src/FRP/Reactive/Internal/Behavior.hs b/src/FRP/Reactive/Internal/Behavior.hs deleted file mode 100755 index 1b2f283..0000000 --- a/src/FRP/Reactive/Internal/Behavior.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving - , FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Behavior --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Representation of reactive behaviors ----------------------------------------------------------------------- - -module FRP.Reactive.Internal.Behavior (BehaviorG(..), beh, unb) where - -import Prelude hiding (zip,unzip) - -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative(pure),liftA2) - --- TypeCompose -import Control.Compose ((:.)(..),unO) -import Data.Zip (Zip(..),Unzip(..)) - -import qualified FRP.Reactive.Reactive as R --- import FRP.Reactive.Reactive (TimeT) -import FRP.Reactive.Fun - - --- Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in --- a type composition to get 'Functor' and 'Applicative' for free. - --- | Reactive behaviors. They can be understood in terms of a simple --- model (denotational semantics) as functions of time, namely @at :: --- BehaviorG t a -> (t -> a)@. --- --- The semantics of 'BehaviorG' instances are given by corresponding --- instances for the semantic model (functions). See --- <http://conal.net/blog/posts/simplifying-semantics-with-type-class-morphisms/>. --- --- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at` --- t == f (r `at` t)@. --- --- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s --- \<*\> at t@. That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t --- == (s `at` t) (r `at` t)@. --- --- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at --- . at rr)@. That is, @return a `at` t == a@, and @join rr `at` t == --- (rr `at` t) `at` t@. As always, @(r >>= f) == join (fmap f r)@. --- @at (r >>= f) == at r >>= at . f@. --- --- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then --- @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend --- == liftA2 mappend@. That is, @mempty `at` t == mempty@, and @(r --- `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@ -newtype BehaviorG tr tf a = Beh { unBeh :: (R.ReactiveG tr :. Fun tf) a } - deriving (Monoid,Functor,Applicative) - --- Standard Monoid instance for Applicative applied to Monoid. Used by --- @deriving Monoid@ above. -instance (Applicative (R.ReactiveG tr :. Fun tf), Monoid a) - => Monoid ((R.ReactiveG tr :. Fun tf) a) where - { mempty = pure mempty; mappend = liftA2 mappend } - --- Standard 'Zip' for an 'Applicative' -instance (Ord tr, Bounded tr) => Zip (BehaviorG tr tf) where zip = liftA2 (,) - --- Standard 'Unzip' for a 'Functor' -instance Unzip (BehaviorG tr tf) where {fsts = fmap fst; snds = fmap snd} - --- | 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/Chan.hs b/src/FRP/Reactive/Internal/Chan.hs deleted file mode 100755 index 46728b6..0000000 --- a/src/FRP/Reactive/Internal/Chan.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : FRP.Reactive.Internal.Chan --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (concurrency) --- --- Unbounded channels. --- ------------------------------------------------------------------------------ - -module FRP.Reactive.Internal.Chan - ( - -- * The 'Chan' type - Chan, -- abstract - - -- * Operations - newChan, -- :: IO (Chan a) - writeChan, -- :: Chan a -> a -> IO () - readChan, -- :: Chan a -> IO a - dupChan, -- :: Chan a -> IO (Chan a) - unGetChan, -- :: Chan a -> a -> IO () - isEmptyChan, -- :: Chan a -> IO Bool - - -- * Stream interface - getChanContents, -- :: Chan a -> IO [a] - writeList2Chan, -- :: Chan a -> [a] -> IO () - -- * New stuff - weakChanWriter - ) where - -import Prelude - -import System.IO.Unsafe ( unsafeInterleaveIO ) -import Control.Concurrent.MVar -import Data.Typeable - - -import System.Mem.Weak (mkWeak,deRefWeak) - - -#include "Typeable.h" - --- A channel is represented by two @MVar@s keeping track of the two ends --- of the channel contents,i.e., the read- and write ends. Empty @MVar@s --- are used to handle consumers trying to read from an empty channel. - --- |'Chan' is an abstract type representing an unbounded FIFO channel. -data Chan a - = Chan (MVar (Stream a)) - (MVar (Stream a)) - -INSTANCE_TYPEABLE1(Chan,chanTc,"Chan") - -type Stream a = MVar (ChItem a) - -data ChItem a = ChItem a (Stream a) - --- See the Concurrent Haskell paper for a diagram explaining the --- how the different channel operations proceed. - --- @newChan@ sets up the read and write end of a channel by initialising --- these two @MVar@s with an empty @MVar@. - --- |Build and returns a new instance of 'Chan'. -newChan :: IO (Chan a) -newChan = do - hole <- newEmptyMVar - readVar <- newMVar hole - writeVar <- newMVar hole - return (Chan readVar writeVar) - --- To put an element on a channel, a new hole at the write end is created. --- What was previously the empty @MVar@ at the back of the channel is then --- filled in with a new stream element holding the entered value and the --- new hole. - --- |Write a value to a 'Chan'. -writeChan :: Chan a -> a -> IO () -writeChan (Chan _ writeVar) val = do - new_hole <- newEmptyMVar - modifyMVar_ writeVar $ \old_hole -> do - putMVar old_hole (ChItem val new_hole) - return new_hole - --- |Read the next value from the 'Chan'. -readChan :: Chan a -> IO a -readChan (Chan readVar _) = do - modifyMVar readVar $ \read_end -> do - (ChItem val new_read_end) <- readMVar read_end - -- Use readMVar here, not takeMVar, - -- else dupChan doesn't work - return (new_read_end, val) - --- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to --- either channel from then on will be available from both. Hence this creates --- a kind of broadcast channel, where data written by anyone is seen by --- everyone else. -dupChan :: Chan a -> IO (Chan a) -dupChan (Chan _ writeVar) = do - hole <- readMVar writeVar - newReadVar <- newMVar hole - return (Chan newReadVar writeVar) - --- |Put a data item back onto a channel, where it will be the next item read. -unGetChan :: Chan a -> a -> IO () -unGetChan (Chan readVar _) val = do - new_read_end <- newEmptyMVar - modifyMVar_ readVar $ \read_end -> do - putMVar new_read_end (ChItem val read_end) - return new_read_end - --- |Returns 'True' if the supplied 'Chan' is empty. -isEmptyChan :: Chan a -> IO Bool -isEmptyChan (Chan readVar writeVar) = do - withMVar readVar $ \r -> do - w <- readMVar writeVar - let eq = r == w - eq `seq` return eq - --- Operators for interfacing with functional streams. - --- |Return a lazy list representing the contents of the supplied --- 'Chan', much like 'System.IO.hGetContents'. -getChanContents :: Chan a -> IO [a] -getChanContents ch - = unsafeInterleaveIO (do - x <- readChan ch - xs <- getChanContents ch - return (x:xs) - ) - --- |Write an entire list of items to a 'Chan'. -writeList2Chan :: Chan a -> [a] -> IO () -writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) - - ----- New bit: - --- | A weak channel writer. Sustained by the read head. Thus channel --- consumers keep channel producers alive. -weakChanWriter :: Chan a -> IO (IO (Maybe (a -> IO ()))) -weakChanWriter ch@(Chan readVar _) = - fmap deRefWeak (mkWeak readVar (writeChan ch) Nothing) diff --git a/src/FRP/Reactive/Internal/Clock.hs b/src/FRP/Reactive/Internal/Clock.hs deleted file mode 100755 index cdf3d56..0000000 --- a/src/FRP/Reactive/Internal/Clock.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Clock --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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 -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 deleted file mode 100755 index 91a31a7..0000000 --- a/src/FRP/Reactive/Internal/Fun.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Fun --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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 deleted file mode 100755 index 0ebd7ae..0000000 --- a/src/FRP/Reactive/Internal/Future.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Future --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Representation of future values ----------------------------------------------------------------------- - -module FRP.Reactive.Internal.Future - ( - -- * Time & futures - Time - , FutureG(..), isNeverF, inFuture, inFuture2 - , runF - ) where - - -import Control.Applicative (Applicative(..)) - -import Control.Comonad (Copointed,Comonad) - -import Test.QuickCheck - -import FRP.Reactive.Internal.Misc (Sink) -import Data.Max -import Data.PairMonad () - - --- | Time used in futures. The parameter @t@ can be any @Ord@ and --- @Bounded@ type. Pure values have time 'minBound', while --- never-occurring futures have time 'maxBound.' --- type Time t = Max (AddBounds t) - -type Time = Max - - --- | A future value of type @a@ with time type @t@. Simply a --- time\/value pair. Particularly useful with time types that have --- non-flat structure. -newtype FutureG t a = Future { unFuture :: (Time t, a) } - deriving (Functor, Applicative, Monad, Copointed, Comonad {-, Show-} - , Arbitrary, CoArbitrary) - -isNeverF :: (Bounded t, Eq t) => FutureG t t1 -> Bool -isNeverF (Future (t,_)) = t == maxBound - -instance (Eq t, Eq a, Bounded t) => Eq (FutureG t a) where - Future a == Future b = - (fst a == maxBound && fst b == maxBound) || a == b - --- When I drop @AddBounds@, I use @maxBound@ as infinity/never. I'm --- uncomfortable with this choice, however. Consider a small type like --- @Bool@ for @t@. - - -instance (Show t, Show a, Eq t, Bounded t) => Show (FutureG t a) where --- show (Future (Max t, a)) | t == maxBound = "<never>" --- | otherwise = "<" ++ show t ++ "," ++ show a ++ ">" - show u | isNeverF u = "<never>" - show (Future (Max t, a)) = "<" ++ show t ++ "," ++ show a ++ ">" - --- The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance --- of 'Max'. - - --- | 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)) = sync t >> io diff --git a/src/FRP/Reactive/Internal/IVar.hs b/src/FRP/Reactive/Internal/IVar.hs deleted file mode 100755 index c21282e..0000000 --- a/src/FRP/Reactive/Internal/IVar.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} --- {-# OPTIONS_GHC -fno-state-hack #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.IVar --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Write-once variables. ----------------------------------------------------------------------- - -module FRP.Reactive.Internal.IVar - ( IVar, newIVar, readIVar, tryReadIVar, writeIVar - ) where - - -import Control.Concurrent.MVar -import Control.Applicative ((<$>)) -import System.IO.Unsafe (unsafePerformIO) - -newtype IVar a = IVar (MVar a) - -newIVar :: IO (IVar a) -newIVar = 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 $ do -- putStrLn "readIVar" - 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 - -{- - --- From: Bertram Felgenhauer <int-e@gmx.de> --- to: conal@conal.net --- date: Mon, Nov 10, 2008 at 1:02 PM --- subject: About IVars - --- Interestingly, the code triggers a bug in ghc; you have to compile --- it with -fno-state-hack if you enable optimization. (Though Simon --- Marlow says that it's not the state hack's fault. See --- http://hackage.haskell.org/trac/ghc/ticket/2756) - --- Hm: ghc balks at {-# OPTIONS_GHC -fno-state-hack #-} - - --- with a few tweaks by conal - -import Control.Concurrent.MVar -import System.IO.Unsafe (unsafePerformIO) - --- an IVar consists of --- a) A lock for the writers. (This avoids the bug explained above.) --- b) An MVar to put the value into --- c) The value of the IVar. This is the main difference between --- our implementations. -data IVar a = IVar (MVar ()) (MVar a) a - --- Creating an IVar creates two MVars and sets up a suspended --- takeMVar for reading the value. --- It relies on unsafePerformIO to execute its body at most once; --- As far as I know this is true since ghc 6.6.1 -- see --- http://hackage.haskell.org/trac/ghc/ticket/986 -newIVar :: IO (IVar a) -newIVar = do - lock <- newMVar () - trans <- newEmptyMVar - let {-# NOINLINE value #-} - value = unsafePerformIO $ takeMVar trans - return (IVar lock trans value) - --- Reading an IVar just returns its value. -readIVar :: IVar a -> a -readIVar (IVar _ _ value) = value - --- Writing an IVar takes the writer's lock and writes the value. --- (To match your interface, use takeMVar instead of tryTakeMVar) - -writeIVar :: IVar a -> a -> IO () -writeIVar (IVar lock trans _) value = do - a <- tryTakeMVar lock - case a of - Just () -> putMVar trans value - Nothing -> error "writeIVar: already written" - --- writeIVar :: IVar a -> a -> IO Bool --- writeIVar (IVar lock trans _) value = do --- a <- tryTakeMVar lock --- case a of --- Just _ -> putMVar trans value >> return True --- Nothing -> return False - --- I didn't originally support tryReadIVar, but it's easily implemented, --- too. -tryReadIVar :: IVar a -> IO (Maybe a) -tryReadIVar (IVar lock _ value) = fmap f (isEmptyMVar lock) - where - f True = Just value - f False = Nothing - --- tryReadIVar (IVar lock _ value) = do --- empty <- isEmptyMVar lock --- if empty then return (Just value) else return Nothing - --} diff --git a/src/FRP/Reactive/Internal/Misc.hs b/src/FRP/Reactive/Internal/Misc.hs deleted file mode 100755 index 4d2ba91..0000000 --- a/src/FRP/Reactive/Internal/Misc.hs +++ /dev/null @@ -1,20 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Misc --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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 deleted file mode 100755 index 5615ccc..0000000 --- a/src/FRP/Reactive/Internal/Reactive.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -Wall #-} - ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Reactive --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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(..), isNeverE, 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 binary 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) ---------------------------------------------------------------------} - -isNeverE :: (Bounded t, Eq t) => EventG t a -> Bool -isNeverE = isNeverF . eFuture - --- | Make the event into a list of futures -eFutures :: (Bounded t, Eq t) => EventG t a -> [FutureG t a] -eFutures e | isNeverE e = [] -eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e - --- TODO: redefine 'eFutures' as an unfold - --- TODO: does this isNeverE interfere with laziness? Does it need an unamb? - --- Show a future -sFuture :: (Show t, Show a) => FutureG t a -> String -sFuture = show . unFuture - --- sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")" --- sFuture (Future (Max MaxBound,_)) = "(infty,_)" --- sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")" - --- TODO: Better re-use in sFuture. - --- Truncated show -sFutures :: (Show t, Show a) => [FutureG t a] -> String - --- sFutures = show - --- This next implementation blocks all output until far future occurrences --- are detected, which causes problems for debugging. I like the "...", --- so look for another implementation. - --- sFutures fs = --- let maxleng = 20 --- a = (intersperse "->" . map sFuture) fs --- inf = length (take maxleng a) == maxleng --- in --- if not inf then concat a --- else concat (take maxleng a) ++ "..." - --- This version uses a lazier intersperse --- sFutures = take 100 . concat . intersperse' "->" . map sFuture - --- The following version adds "..." in case of truncation. - -sFutures fs = leading early ++ trailing late - where - (early,late) = splitAt 20 fs - leading = concat . intersperse' "->" . map sFuture - trailing [] = "" - trailing _ = "-> ..." - - --- TODO: clean up sFutures def: use intercalate, concat before trimming, --- and define&use a general function for truncating and adding "...". --- Test. - -instance (Eq t, Bounded t, Show t, Show a) => Show (EventG t a) where - show = ("Event: " ++) . sFutures . eFutures - -instance (Eq t, Bounded t, Show t, Show a) => Show (ReactiveG t a) 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, Bounded t) => Sink t -> Sink (EventG t Action) -runE sync ~(Event (Future (Max t,r))) - | t == maxBound = return () -- finished! - | otherwise = sync t >> runR sync r - --- In most cases, the value of t won't be known ahead of time, so just --- evaluating t will do the necessary waiting. - - --- | Run an event in a new thread, using the given time sink to sync time. -forkE :: (Ord t, Bounded 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 :: (Bounded t, Ord t) => Sink t -> Sink (ReactiveG t Action) -runR sync (act `Stepper` e) = act >> runE sync e - --- | Run a reactive value in a new thread, using the given time sink to --- sync time. The initial action happens in the current thread. -forkR :: (Ord t, Bounded t) => Sink t -> ReactiveG t Action -> IO ThreadId -forkR = (fmap.fmap) forkIO runR - ------ - --- intersperse :: a -> [a] -> [a] --- intersperse _ [] = [] --- intersperse _ [x] = [x] --- intersperse sep (x:xs) = x : sep : intersperse sep xs - --- Lazier intersperse - -intersperse' :: a -> [a] -> [a] -intersperse' _ [] = [] -intersperse' sep (x:xs) = x : continue xs - where - continue [] = [] - continue xs' = sep : intersperse' sep xs' - diff --git a/src/FRP/Reactive/Internal/Serial.hs b/src/FRP/Reactive/Internal/Serial.hs deleted file mode 100755 index c8c66f6..0000000 --- a/src/FRP/Reactive/Internal/Serial.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# 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 : GNU AGPLv3 (see COPYING) --- --- 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 deleted file mode 100755 index b3f055e..0000000 --- a/src/FRP/Reactive/Internal/TVal.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TypeOperators #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.TVal --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Timed values. A primitive interface for futures. ----------------------------------------------------------------------- - -module FRP.Reactive.Internal.TVal - ((:-->), (:+->), makeEvent) where - -import Control.Applicative ((<$>)) -- ,liftA2 --- import Control.Monad (forever) -import Control.Concurrent (forkIO,yield) -- , ThreadId - --- import Control.Concurrent.Chan hiding (getChanContents) -import FRP.Reactive.Internal.Chan - ---import System.Mem.Weak (mkWeakPtr,deRefWeak) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) - -import Data.Stream (Stream(..)) -- ,streamToList - -import Data.Unamb (unamb,assuming) - -import Data.AddBounds -import FRP.Reactive.Improving (Improving(..)) -import FRP.Reactive.Future (FutureG,future) -import FRP.Reactive.Reactive (Event,TimeT,ITime) -import FRP.Reactive.PrimReactive (futureStreamE) - -import FRP.Reactive.Internal.Misc (Sink) -import FRP.Reactive.Internal.Clock -import FRP.Reactive.Internal.Timing (sleepPast) -import FRP.Reactive.Internal.IVar --- import FRP.Reactive.Internal.Reactive (isNeverE) - --- | An @a@ that's fed by a @b@ -type b :--> a = (Sink b, a) - --- | Make a '(:-->)'. -type b :+-> a = IO (b :--> a) - --- | 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 } - -makeTVal :: Clock TimeT -> a :+-> TVal TimeT a -makeTVal (Clock getT _) = do -- putStrLn "makeTVal" - f <$> newIVar - where - f v = (sink, TVal (readIVar v) (unsafePerformIO . undefAt)) - where - undefAt t = - -- Read v after time t. If it's undefined, then it wasn't defined - -- at t. If it is defined, then see whether it was defined before t. - do -- putStrLn $ "undefAt " ++ show t - -- ser $ putStrLn $ "sleepPast " ++ show t - sleepPast getT t --- maybe False ((< t) . fst) <$> tryReadIVar v - - value <- tryReadIVar v - case value of - -- We're past t, if it's not defined now, it wasn't at t. - Nothing -> return False - -- If it became defined before t, then it's defined now. - Just (t',_) -> return (t' < t) - - sink a = do -- putStrLn "sink" - t <- getT - writeIVar v (t,a) - - -- sink a = getT >>= writeIVar v . flip (,) 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 (AddBounds t)) a -tValFuture v = future (tValImp v) (snd (timeVal v)) - --- | 'TVal' as 'Improving' -tValImp :: Ord t => TVal t a -> Improving (AddBounds t) -tValImp v = Imp ta (\ t' -> assuming (not (definedAt' v t')) GT - `unamb` (ta `compare` t')) - where - ta = NoBound (fst (timeVal v)) - -definedAt' :: TVal t a -> AddBounds t -> Bool -definedAt' _ MinBound = False -definedAt' tval (NoBound t) = definedAt tval t -definedAt' _ MaxBound = True - --- definedAt' _ _ = error "definedAt': non-NoBound" - - --- -- | Make a new event and a sink that writes to it. Uses the given --- -- clock to serialize and time-stamp. --- makeEvent :: Clock TimeT -> a :+-> Event a --- makeEvent clock = --- do chanA <- newChan --- chanF <- newChan --- spin $ do --- -- Get the skeleton tval written out immediately. Details will --- -- be added --- (tval,snka) <- makeTVal clock --- writeChan chanF (tValFuture tval) --- readChan chanA >>= snka --- futs <- getChanContents chanF --- return (futuresE futs, writeChanY chanA) - --- makeTVal :: Clock TimeT -> a :+-> TVal TimeT a - - --- | Make a connected sink/future pair. The sink may only be written to once. -makeFuture :: Clock TimeT -> (a :+-> FutureG ITime a) -makeFuture = (fmap.fmap.fmap) 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 -> forall a. Show a => (a :+-> Event a) -makeEvent clock = (fmap.fmap) futureStreamE (listSink (makeFuture clock)) - --- makeEvent clock = --- do (snk,s) <- listSink (makeFuture clock) --- let e = futureStreamE s --- putStrLn $ "isNeverE e == " ++ show (isNeverE e) --- -- putStrLn $ "makeEvent: e == " ++ show e --- return (snk, e) - - --- Turn a single-feedable into a multi-feedable - --- listSink :: (b :+-> a) -> (b :+-> [a]) --- listSink mk = do chanA <- newChan --- chanB <- newChan --- spin $ do --- (snk,a) <- mk --- -- putStrLn "writing input" --- writeChan chanA a --- readChan chanB >>= snk --- as <- getChanContents chanA --- return (writeChanY chanB, as) - -listSink :: Show a => (b :+-> a) -> (b :+-> Stream a) - --- listSink mk = do chanA <- newChan --- chanB <- newChan --- spin $ do --- (snk,a) <- mk --- -- putStrLn "writing input" --- writeChan chanA a --- readChan chanB >>= snk --- as <- getChanStream chanA --- return (writeChanY chanB, as) --- spin :: IO a -> IO ThreadId --- spin = forkIO . forever - - --- Yield control after channel write. Helps responsiveness --- tremendously. -writeChanY :: Chan a -> Sink a -writeChanY ch x = writeChan ch x >> yield --- Equivalently: --- writeChanY = (fmap.fmap) (>> yield) writeChan - - - - --- I want to quit gathing input when no one is listening, to eliminate a --- space leak. Here's my first attempt: - --- listSink mk = do chanA <- newChan --- chanB <- newChan --- wchanA <- mkWeakPtr chanA Nothing --- let loop = --- do mbch <- deRefWeak wchanA --- case mbch of --- Nothing -> --- do -- putStrLn "qutting" --- return () --- Just ch -> --- do -- putStrLn "add value" --- (a,snk) <- mk --- writeChan ch a --- readChan chanB >>= snk --- loop --- forkIO loop --- as <- getChanContents chanA --- return (writeChanY chanB, as) - --- This attempt fails. The weak reference gets lost almost immediately. --- My hunch: ghc optimizes away the Chan representation when compiling --- getChanContents, and just holds onto the read and write ends (mvars), --- via a technique described at ICFP 07. I don't know how to get a --- reliable weak reference, without altering Control.Concurrent.Chan. --- --- Apparently this problem has popped up before. See --- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer - - -listSink mk = do -- putStrLn "listSink" - chanA <- newChan - chanB <- newChan - --- let loop = do (snk,a) <- mk --- -- putStrLn "sank" --- writeChanY chanA a --- readChan chanB >>= snk --- loop - --- wwriteA <- weakChanWriter chanA --- let loop = do (snk,a) <- mk --- mbw <- wwriteA --- case mbw of --- Nothing -> putStrLn "bailing" --- Just writeA -> do writeA a >> yield --- readChan chanB >>= snk --- loop - - wwriteA <- weakChanWriter chanA - let loop = do mbw <- wwriteA - case mbw of - Nothing -> - do -- putStrLn "bailing" - return () - Just writeA -> - do -- putStrLn "writing to weak channel" - (snk,a) <- mk - writeA a - -- putStrLn "wrote" - yield - readChan chanB >>= snk - loop - - _ <- forkIO loop - as <- getChanStream chanA - - -- debugging. defeats freeing. - -- forkIO $ print $ streamToList as - - return (writeChanY chanB, as) - - --- I hadn't been yielding after writing to chanA. What implications? - - --- | Variation on 'getChanContents', returning a stream instead of a --- list. Note that 'getChanContents' only makes infinite lists. I'm --- hoping to get some extra laziness by using irrefutable 'Cons' pattern --- when consuming the stream. -getChanStream :: Chan a -> IO (Stream a) - --- getChanStream ch = unsafeInterleaveIO $ --- liftA2 Cons (readChan ch) (getChanStream ch) - -getChanStream ch - = unsafeInterleaveIO (do - x <- readChan ch - xs <- getChanStream ch - return (Cons x xs) - ) - - -{- --} diff --git a/src/FRP/Reactive/Internal/Timing.hs b/src/FRP/Reactive/Internal/Timing.hs deleted file mode 100755 index 9784622..0000000 --- a/src/FRP/Reactive/Internal/Timing.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Internal.Timing --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- ----------------------------------------------------------------------- - -module FRP.Reactive.Internal.Timing - (adaptE,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 Data.AddBounds - -import FRP.Reactive.Reactive (exactNB,TimeT,Event) -import FRP.Reactive.Improving (Improving,exact) -import FRP.Reactive.Behavior (Behavior) - -import FRP.Reactive.Internal.Misc (Action,Sink) -import FRP.Reactive.Internal.Reactive (forkR,runE) -import FRP.Reactive.Internal.Behavior (unb) -import FRP.Reactive.Internal.Fun -import FRP.Reactive.Internal.Clock (makeClock,cGetTime) - - - --- | Execute an action-valued event. -adaptE :: Sink (Event Action) -adaptE e = do clock <- makeClock - runE (sleepPast (cGetTime clock) . exactNB) e - - --- | 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 = threadDelay . ceiling . (1.0e6 *) - --- | Sleep past a given time -sleepPast :: IO TimeT -> Sink TimeT -sleepPast getT !target = - -- Snooze until strictly after the target. - do -- The strict evaluation of target is essential here. - -- (See bang pattern.) Otherwise, the next line will grab a - -- time before a possibly long block, and then sleep much - -- longer than necessary. - now <- getT --- putStrLn $ "sleepPast: now == " ++ show now --- ++ ", target == " ++ show target - unless (now > target) $ - sleep (target-now) -- >> loop - --- | Variant of 'sleepPast', taking a possibly-infinite time -sleepPast' :: IO TimeT -> Sink (AddBounds TimeT) -sleepPast' _ MinBound = return () -sleepPast' getT (NoBound target) = sleepPast getT target -sleepPast' _ MaxBound = error "sleepPast MaxBound. Expected??" diff --git a/src/FRP/Reactive/LegacyAdapters.hs b/src/FRP/Reactive/LegacyAdapters.hs deleted file mode 100755 index 01dd0af..0000000 --- a/src/FRP/Reactive/LegacyAdapters.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.LegacyAdapters --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Tools for making Reactive adapters for imperative (\"legacy\") --- libraries. ----------------------------------------------------------------------- - -module FRP.Reactive.LegacyAdapters - ( Sink, Action - , Clock, makeClock, cGetTime - , adaptE, mkUpdater - , module FRP.Reactive.Internal.TVal - ) where - -import FRP.Reactive.Internal.Misc (Sink,Action) -import FRP.Reactive.Internal.Clock (Clock,makeClock,cGetTime) -import FRP.Reactive.Internal.TVal -import FRP.Reactive.Internal.Timing (adaptE,mkUpdater) - diff --git a/src/FRP/Reactive/Num-inc.hs b/src/FRP/Reactive/Num-inc.hs deleted file mode 100755 index bbbf121..0000000 --- a/src/FRP/Reactive/Num-inc.hs +++ /dev/null @@ -1,112 +0,0 @@ ----------------------------------------------------------------------- --- Meta-Module : Num-inc --- Copyright : (c) Conal Elliott 2008 --- License : BSD3 --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Instances of Num classes for applicative functors. To be #include'd --- after defining APPLICATIVE as the applicative functor name. --- --- You'll also have to import 'pure' and 'liftA2' from --- "Control.Applicative". ----------------------------------------------------------------------- - --- This module still needs some think work. It now assumes that Eq, Ord, --- Enum, and Show are undefined, which is not a good assumption. For --- instance, Maybe. - - -noOv :: String -> String -> a -noOv ty meth = error $ meth ++ ": No overloading for " ++ ty - -noFun :: String -> a -noFun = noOv "behavior" - --- Eq & Show are prerequisites for Num, so they need to be faked here -instance Eq (APPLICATIVE b) where - (==) = noFun "(==)" - (/=) = noFun "(/=)" - -instance Ord b => Ord (APPLICATIVE b) where - min = liftA2 min - max = liftA2 max - -instance Enum b => Enum (APPLICATIVE b) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = noFun "fromEnum" - enumFrom = noFun "enumFrom" - enumFromThen = noFun "enumFromThen" - enumFromTo = noFun "enumFromTo" - enumFromThenTo = noFun "enumFromThenTo" - -instance Show (APPLICATIVE b) where - show = noFun "show" - showsPrec = noFun "showsPrec" - showList = noFun "showList" - -instance Num b => Num (APPLICATIVE b) where - negate = fmap negate - (+) = liftA2 (+) - (*) = liftA2 (*) - fromInteger = pure . fromInteger - abs = fmap abs - signum = fmap signum - -instance (Num b, Ord b) => Real (APPLICATIVE b) where - toRational = noFun "toRational" - -instance Integral b => Integral (APPLICATIVE b) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem = (fmap.fmap) unzip (liftA2 quotRem) - divMod = (fmap.fmap) unzip (liftA2 divMod) - toInteger = noFun "toInteger" - -instance Fractional b => Fractional (APPLICATIVE b) where - recip = fmap recip - fromRational = pure . fromRational - -instance Floating b => Floating (APPLICATIVE 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 - -instance RealFrac b => RealFrac (APPLICATIVE b) where - properFraction = noFun "properFraction" - truncate = noFun "truncate" - round = noFun "round" - ceiling = noFun "ceiling" - floor = noFun "floor" - -instance RealFloat b => RealFloat (APPLICATIVE b) where - floatRadix = noFun "floatRadix" - floatDigits = noFun "floatDigits" - floatRange = noFun "floatRange" - decodeFloat = noFun "decodeFloat" - encodeFloat = (fmap.fmap) pure encodeFloat - exponent = noFun "exponent" - significand = noFun "significand" - scaleFloat n = fmap (scaleFloat n) - isNaN = noFun "isNaN" - isInfinite = noFun "isInfinite" - isDenormalized = noFun "isDenormalized" - isNegativeZero = noFun "isNegativeZero" - isIEEE = noFun "isIEEE" - atan2 = liftA2 atan2 diff --git a/src/FRP/Reactive/Num.hs b/src/FRP/Reactive/Num.hs deleted file mode 100755 index edadfc8..0000000 --- a/src/FRP/Reactive/Num.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Num --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Numeric class instances for behaviors ----------------------------------------------------------------------- - -module FRP.Reactive.Num () where - -import Prelude hiding (zip,unzip) - -import FRP.Reactive.Behavior -import Control.Applicative - -import Data.Zip - -noOv :: String -> String -> a -noOv ty meth = error $ meth ++ ": No overloading for " ++ ty - -noFun :: String -> a -noFun = noOv "behavior" - --- 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 Enum a => Enum (Behavior a) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = noFun "fromEnum" - enumFrom = noFun "enumFrom" - enumFromThen = noFun "enumFromThen" - enumFromTo = noFun "enumFromTo" - enumFromThenTo = noFun "enumFromThenTo" - -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 (Num a, Ord a) => Real (Behavior a) where - toRational = noFun "toRational" - -instance Integral a => Integral (Behavior a) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem = (fmap.fmap) unzip (liftA2 quotRem) - divMod = (fmap.fmap) unzip (liftA2 divMod) - toInteger = noFun "toInteger" - -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 - -instance RealFrac a => RealFrac (Behavior a) where - properFraction = noFun "properFraction" - truncate = noFun "truncate" - round = noFun "round" - ceiling = noFun "ceiling" - floor = noFun "floor" - -instance RealFloat a => RealFloat (Behavior a) where - floatRadix = noFun "floatRadix" - floatDigits = noFun "floatDigits" - floatRange = noFun "floatRange" - decodeFloat = noFun "decodeFloat" - encodeFloat = (fmap.fmap) pure encodeFloat - exponent = noFun "exponent" - significand = noFun "significand" - scaleFloat n = fmap (scaleFloat n) - isNaN = noFun "isNaN" - isInfinite = noFun "isInfinite" - isDenormalized = noFun "isDenormalized" - isNegativeZero = noFun "isNegativeZero" - isIEEE = noFun "isIEEE" - atan2 = liftA2 atan2 diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs deleted file mode 100755 index 60cd3ff..0000000 --- a/src/FRP/Reactive/PrimReactive.hs +++ /dev/null @@ -1,957 +0,0 @@ -{-# 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 : GNU AGPLv3 (see COPYING) --- --- 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, futureStreamE, listEG, atTimesG, atTimeG - , snapshotWith, accumE, accumR, once - , withRestE, untilE - , justE, filterE - -- , traceE, traceR - -- , mkEvent, mkEventTrace, mkEventShow - , eventOcc - -- * To be moved elsewhere - , joinMaybes, filterMP, result - -- * To be removed when it gets used somewhere - , isMonotoneR - -- * Testing - , batch, infE, monoid_E - -- * Temporary exports, while debugging - -- , snap, merge - ) where - -import Prelude hiding (zip,zipWith) - -import Data.Monoid -import Control.Applicative -import Control.Arrow (first) -import Control.Monad -import Data.Function (on) --- import Debug.Trace (trace) - --- TODO: eliminate the needs for this stuff. -import Control.Concurrent (threadDelay) -import Control.Exception (evaluate) -import System.IO.Unsafe - -import Data.Stream (Stream(..)) - -import Control.Comonad - -import Test.QuickCheck -import Test.QuickCheck.Instances -import Test.QuickCheck.Checkers -import Test.QuickCheck.Classes --- import Data.List - --- TypeCompose -import Control.Compose ((:.)(..), inO2, Monoid_f(..)) -import Data.Zip -import Control.Instances () -- Monoid (IO ()) - - -import Data.Unamb (unamb, assuming) -import Data.Unamb (race) -- eliminate - --- import Data.Max --- import Data.AddBounds -import FRP.Reactive.Future hiding (batch) -import FRP.Reactive.Internal.Reactive - -{-------------------------------------------------------------------- - 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 (Bounded t, Eq t, Eq a, EqProp t, EqProp a) => EqProp (EventG t a) where - a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b) - where - f = take 20 . eFutures - --- TODO: work less and reach further per (=-=). - -arbitraryE :: (Num t, Ord t, Bounded t, Arbitrary t, Arbitrary u) => Gen (EventG t u) -arbitraryE = frequency - [ -- (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList) - (4, liftA futuresE futureList) - ] - where - -- earliestFuture = Future . (,) (Max MinBound) - -- addStart = (:).earliestFuture - futureList = futureListFinite - -- frequency [(10, futureListFinite), (1,futureListInf)] - futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary --- futureListInf = --- liftA2 (zipWith future) (resize 10 nondecreasingInf) --- (infiniteList arbitrary) - -instance (Arbitrary t, Ord t, Bounded t, Num t, Arbitrary a) => Arbitrary (EventG t a) where - arbitrary = arbitraryE - -instance (CoArbitrary t, CoArbitrary a) => CoArbitrary (EventG t a) where - coarbitrary = coarbitrary . eFuture - ----- - --- Arbitrary works just like pairs: - --- instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where --- arbitrary = liftA2 Stepper arbitrary arbitrary --- coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a - -instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where - arbitrary = liftA2 Stepper arbitrary arbitrary - -instance (CoArbitrary t, CoArbitrary a) => CoArbitrary (ReactiveG t a) where - coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a - -instance (Ord t, Bounded t) => Model (ReactiveG t a) (t -> a) where - model = rat - -instance (Ord t, Bounded 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, Bounded t) => Monoid (EventG t a) where - mempty = Event mempty - mappend = inEvent2 merge - --- Standard instance for Applicative of Monoid -instance (Ord t, Bounded t, Monoid a) => Monoid (ReactiveG t a) where - mempty = pure mempty - mappend = liftA2 mappend - --- | Merge two 'Future' reactives into one. -merge :: (Ord t, Bounded t) => Binop (FutureG t (ReactiveG t a)) - --- The following two lines seem to be too strict and are causing --- reactive to lock up. I.e. the time argument of one of these --- must have been _|_, so when we pattern match against it, we --- block. --- --- On the other hand, they patch a massive space leak in filterE. Perhaps --- there's an unamb solution. - -u `merge` v = - assuming (isNeverF u) v `unamb` - assuming (isNeverF v) u `unamb` - (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) - --- TODO: redefine via parIdentity from Data.Unamb - --- u `merge` v | isNever u = v --- | isNever v = u - --- Future (Max MaxBound,_) `merge` v = v --- u `merge` Future (Max MaxBound,_) = u - --- u `merge` v = --- (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) - --- What's going on in this 'merge' definition? Try two different --- future paths. If u arrives before v (or simultaneously), then --- begin as u begins and then merge v with the rest of u. Otherwise, --- 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 = inEvent.fmap.fmap - -instance Functor (ReactiveG t) where - fmap f ~(a `Stepper` e) = f a `stepper` fmap f e - --- standard instance -instance (Ord t, Bounded t) => Applicative (EventG t) where - pure = return - (<*>) = ap --- _ <*> (Event (Future (Max MaxBound,_))) = mempty --- x <*> y = x `ap` y - --- standard instance -instance (Ord t, Bounded t) => Alternative (EventG t) where - { empty = mempty; (<|>) = mappend } - -instance (Ord t, Bounded t) => Zip (ReactiveG t) where - -- zip :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b) - (c `Stepper` ce) `zip` (d `Stepper` de) = - (c,d) `accumR` pairEdit (ce,de) - -instance (Ord t, Bounded t) => Applicative (ReactiveG t) where - pure a = a `stepper` mempty - -- Standard definition. See 'Zip'. - rf <*> rx = zipWith ($) rf 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, Bounded t) => Monad (EventG t) where - return a = Event (pure (pure a)) - e >>= f = joinE (fmap f e) - - --- From Jules Bean (quicksilver): - --- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a --- joinE (Event u) = --- Event . join $ --- fmap (\ (e `Stepper` ee) -> --- let (Event uu) = (e `mappend` joinE ee) in uu) --- u - --- plus some fiddling: - -joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a - -joinE (Event u) = Event (u >>= eFuture . g) - where - g (e `Stepper` ee) = e `mappend` joinE ee - --- joinE = inEvent (>>= eFuture . g) --- where --- g (e `Stepper` ee) = e `mappend` joinE ee - - --- | Experimental specialization of 'joinMaybes'. -justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a -justE ~(Event (Future (t, mb `Stepper` e'))) = - assuming (t == maxBound) mempty `unamb` - (inEvent.inFuture.first) (max t) $ - case mb of - Nothing -> justE e' - Just a -> Event (Future (t, a `Stepper` justE e')) - - --- This definition is much more efficient than the following. - --- justE = (>>= maybe mzero return) - --- On the other hand, this simpler definition inserts the necessary max --- applications so that we needn't find a Just in order to have a lower bound. - --- TODO: find and fix the inefficiency. - - - - - --- | Experimental specialization of 'filterMP'. -filterE :: (Ord t, Bounded t) => (a -> Bool) -> EventG t a -> EventG t a -filterE p m = justE (liftM f m) - where - f a | p a = Just a - | otherwise = Nothing - - -{- - --- happy a t b. Same as (a `mappend` b) except takes advantage of knowledge --- that t is a lower bound for the occurences of b. This allows for extra --- laziness. -happy :: (Ord t) => EventG t a -> - Time t -> - EventG t a -> - EventG t a -happy a t b = - assuming (isNeverE a) b `unamb` - assuming (isNeverF b) a `unamb` - happy' a t b ... - - -happy a (Max MaxBound) _ = a -happy (Event (Future (Max MaxBound, _))) _ b = b -happy a@(Event (Future (t0, e `Stepper` ee'))) t b - | 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')) --} - -{- --- Note, joinE should not be called with an infinite list of events that all --- occur at the same time. It can't decide which occurs first. -joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a -joinE (Event (Future (t0h, e `Stepper` ee'))) = - assuming (t0h == maxBound) mempty $ - adjustE t0h (e `mappend` joinE ee') - --- TODO: revisit this def. - - --- Original Version: --- joinE (Event (Future (t0h, e `Stepper` ee'))) = --- adjustE t0h e `mappend` adjustTopE t0h (joinE ee') - -adjustTopE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1 - --- adjustTopE t0h = (inEvent.inFuture.first) (max t0h) - -adjustTopE t0h ~(Event (Future (tah, r))) = - Event (Future (t0h `max` tah,r)) - -adjustE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1 - -adjustE _ e@(Event (Future (Max MaxBound, _))) = e - -adjustE t0h (Event (Future (tah, a `Stepper` e))) = - Event (Future (t1h,a `Stepper` adjustE t1h e)) - where - t1h = t0h `max` tah - --} - --- The two-caseness of adjustE prevents the any info from coming out until --- tah is known to be Max or non-Max. Problem? - --- Is the MaxBound case really necessary? - --- TODO: add adjustE explanation. What's going on and why t1 in the --- recursive call? David's comment: --- 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, Bounded 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 --} - - --- These two joinE defs both lock up in my tests. - - -instance (Ord t, Bounded t) => MonadPlus (EventG t) where - { mzero = mempty; mplus = mappend } - --- Standard instance for Applicative w/ join -instance (Ord t, Bounded t) => Monad (ReactiveG t) where - return = pure - r >>= f = joinR (f <$> r) - - --- -- Temporary --- justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a --- justE = joinMaybes - --- filterE :: (Ord t, Bounded t, Show a) => (a -> Bool) -> EventG t a -> EventG t a --- filterE = filterMP - -{- - --- | Pass through the 'Just' occurrences, stripped. Experimental --- specialization of 'joinMaybes'. -justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a -justE (Event (Future (ta, Just a `Stepper` e'))) = - Event (Future (ta, a `Stepper` justE e')) -justE (Event (Future (ta, Nothing `Stepper` e'))) = - adjustE ta (justE e') - --- The adjustE lets consumers know that the resulting event occurs no --- earlier than ta. - --- | Pass through values satisfying a given predicate. Experimental --- specialization of 'filterMP'. -filterE :: (Ord t, Show a) => (a -> Bool) -> EventG t a -> EventG t a - --- filterE p e = joinMaybes (f <$> e) --- where --- f a | p a = Just a --- | otherwise = Nothing - -filterE _ e@(Event (Future (Max MaxBound, _))) = e - -filterE p (Event (Future (ta, a `Stepper` e'))) = - adjustTopE ta $ - if p a then - Event (Future (ta, a `Stepper` filterE p e')) - else filterE p e' --} - --- The adjustTopE ta guarantees a lower bound even before we've looked at a. - --- filterE p (Event (Future (ta, a `Stepper` e'))) --- | p a = Event (Future (ta, a `Stepper` filterE p e')) --- | otherwise = adjustTopE ta (filterE p e') - --- filterE p (Event (Future (ta, a `Stepper` e'))) = h (filterE p e') --- where --- h | p a = -- trace ("pass " ++ show a) $ --- \ e'' -> Event (Future (ta, a `Stepper` e'')) --- | otherwise = -- trace ("skip " ++ show a) $ --- adjustTopE ta - --- Or maybe move the adjustTopE to the second filterE - --- adjustTopE t0h = (inEvent.inFuture.first) (max t0h) - - --- Laziness problem: no information at all can come out of filterE's --- result until @p a@ is known. - --- filterE p ~(Event (Future (ta, a `Stepper` e'))) = --- Event (Future (ta', r')) --- where --- ta' --- --- if p a then --- Event (Future (ta, a `Stepper` filterE p e')) --- else --- adjustE ta (filterE p e') - - -{-------------------------------------------------------------------- - Operations on events and reactive values ---------------------------------------------------------------------} - --- | 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, Bounded t) => ReactiveG t a -> EventG t a --- rToE (a `Stepper` e) = pure a `mappend` e - --- | Switch between reactive values. -switcher :: (Ord t, Bounded t) => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a -r `switcher` e = join (r `stepper` e) - --- | Reactive 'join' (equivalent to 'join' but slightly more efficient, I think) -joinR :: (Ord t, Bounded 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, Bounded t) => [(t,a)] -> EventG t a -listEG = futuresE . map (uncurry future) - --- | Convert a temporally monotonic list of futures to an event -futuresE :: (Ord t, Bounded 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. - --- | Convert a temporally monotonic stream of futures to an event. Like --- 'futuresE' but it can be lazier, because there's not empty case. -futureStreamE :: (Ord t, Bounded t) => Stream (FutureG t a) -> EventG t a -futureStreamE (~(Cons (Future (t,a)) futs)) = - Event (Future (t, a `stepper` futureStreamE futs)) - --- | Event at given times. See also 'atTimeG'. -atTimesG :: (Ord t, Bounded t) => [t] -> EventG t () -atTimesG = listEG . fmap (flip (,) ()) - --- | Single-occurrence event at given time. -atTimeG :: (Ord t, Bounded t) => t -> EventG t () -atTimeG = atTimesG . pure - --- | Snapshot a reactive value whenever an event occurs and apply a --- combining function to the event and reactive's values. -snapshotWith :: (Ord t, Bounded t) => - (a -> b -> c) -> ReactiveG t b -> EventG t a -> EventG t c - --- snapshotWith f e r = joinMaybes $ fmap h (e `snap` r) --- where --- h (Nothing,_) = Nothing --- h (Just a ,b) = Just (f a b) - --- -- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@ --- -- didn't. --- snap :: forall a b t. (Ord t, Bounded t) => --- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b) --- (b0 `Stepper` eb) `snap` ea = --- assuming (isNeverE ea) mempty $ --- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb) --- where --- fa :: a -> Unop (Maybe a, b) --- fb :: b -> Unop (Maybe a, b) --- fa a (_,b) = (Just a , b) --- fb b _ = (Nothing, b) - --- This next version from Chuan-kai Lin, so that snapshot is lazy enough --- for recursive cases. It leaks when the reactive changes faster than --- the event occurs. - -snapshotWith f r e = - fmap snap $ accumE seed $ fmap advance $ withTimeGE e - where snap (a, sr) = f a (rInit sr) - seed = (error "snapshotWith seed", r) - advance (a, t) (_, sr) = (a, skipRT sr t) - --- | Skip reactive values until the given time. -skipRT :: (Ord t, Bounded t) => ReactiveG t a -> Time t -> ReactiveG t a -r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start = - if t < start then r1 `skipRT` start else r - --- From Beelsebob: - --- snapshotWith f r e@(Event (Future (t,_ `Stepper` ne))) = --- Event (Future (t, v' `stepper` snapshotWith f r ne)) --- where --- Event (Future (_,v' `Stepper` _)) = snapshotWith' f r e --- snapshotWith' f' r' e' = joinMaybes $ fmap h (r' `snap` e') --- 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'. -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, Bounded t) => EventG t a -> EventG t a -once = (inEvent.fmap) (pure . rInit) - --- | Extract a future representing the first occurrence of the event together --- with the event of all occurrences after that one. -eventOcc :: (Ord t) => EventG t a -> FutureG t (a, EventG t a) -eventOcc (Event fut) = (\ (Stepper a e) -> (a,e)) <$> fut - - --- | Access the remainder with each event occurrence. -withRestE :: EventG t a -> EventG t (a, EventG t a) -withRestE = (inEvent.fmap) $ - \ (a `Stepper` e') -> (a,e') `stepper` withRestE e' - - --- | Truncate first event at first occurrence of second event. -untilE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t a -ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb - --- | Truncate first event at the given time. -untilET :: (Ord t, Bounded 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. - - --- | 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, Bounded 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, Bounded t) => ReactiveG t a -> t -> a -rat r = head . rats r . (:[]) - - -{-------------------------------------------------------------------- - Other instances ---------------------------------------------------------------------} - --- Standard instances -instance (Monoid_f f, Ord t, Bounded t) => Monoid_f (ReactiveG t :. f) where - { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) } -instance (Ord t, Bounded t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip - -instance Unzip (ReactiveG t) where {fsts = fmap fst; snds = fmap snd} - --- Standard instances -instance (Ord t, Bounded t) => Monoid_f (EventG t) where - { mempty_f = mempty ; mappend_f = mappend } -instance (Ord t, Bounded t) => Monoid ((EventG t :. f) a) where - { mempty = O mempty; mappend = inO2 mappend } -instance (Ord t, Bounded t) => Monoid_f (EventG t :. f) where - { mempty_f = mempty ; mappend_f = mappend } -instance (Ord t, Bounded t, Cozip f) => Zip (EventG t :. f) where - zip = cozip - --- Standard instance for functors -instance Unzip (EventG t) where {fsts = fmap fst; snds = fmap snd} - - -{-------------------------------------------------------------------- - Comonadic stuff ---------------------------------------------------------------------} - -instance Copointed (EventG t) where - -- E a -> F (R a) -> R a -> a - extract = extract . extract . eFuture - --- Here's the plan for 'duplicate': --- --- E a -> F (R a) -> F (R (R a)) -> F (F (R (R a))) --- -> F (R (F (R a))) -> E (F (R a)) -> E (E a) - - -instance Monoid t => Comonad (EventG t) where - duplicate = - fmap Event . Event . fmap frTOrf . duplicate . fmap duplicate . eFuture - --- This frTOrf definition type-checks. Is it what we want? -frTOrf :: FutureG t (ReactiveG t a) -> ReactiveG t (FutureG t a) -frTOrf ~(Future (ta,e)) = (Future . (,) ta) <$> e - --- TODO: Reconsider E = F :. R . Didn't work with absolute time. What --- about relative time? - -instance (Ord t, Bounded t) => Pointed (ReactiveG t) where - point = (`stepper` mempty) - --- TODO: I think we can bypass mempty and so eliminate the Ord --- constraint. If so, remove Ord tr from 'time' in Behavior. - -instance Copointed (ReactiveG t) where - -- extract = extract . rat - -- Semantically: extract == extract . rat == (`rat` mempty) But mempty - -- is the earliest time (since I'm using the Max monoid *), so here's a - -- cheap alternative that also doesn't require Ord t: - extract (a `Stepper` _) = a - --- extract r == extract (rat r) == rat r mempty - --- * Moreover, mempty is the earliest time in the Sum monoid on --- non-negative values, for relative-time behaviors. - -instance Monoid t => Comonad (ReactiveG t) where - duplicate r@(_ `Stepper` Event u) = - r `Stepper` Event (duplicate <$> u) - --- TODO: Prove the morphism law: --- --- fmap rat . rat . dup == dup . rat - --- Reactive is like the stream comonad --- TODO: try again letting events and reactives be streams of futures. - - -{-------------------------------------------------------------------- - 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 - - --- | Apply a given function inside the results of other functions. --- Equivalent to '(.)', but has a nicer reading when composed -result :: (b -> b') -> ((a -> b) -> (a -> b')) -result = (.) - - -{-------------------------------------------------------------------- - Tests ---------------------------------------------------------------------} - --- 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 - [ - -- monad associativity fails - -- , monad (undefined :: EventG NumT (NumT,T,NumT)) - monoid (undefined :: EventG NumT T) - , monoid (undefined :: ReactiveG NumT [T]) - , monad (undefined :: ReactiveG NumT (NumT,T,NumT)) --- , ("occurence count", --- [("joinE", joinEOccuranceCount)] --- ) - , ("monotonicity", - [ monotonicity2 "<*>" - ((<*>) :: ApTy (EventG NumT) T T) -{- - , monotonicity2 "adjustE" (adjustE - :: Time NumT - -> EventG NumT NumT - -> EventG NumT NumT) --} - , monotonicity "join" (join - :: EventG NumT (EventG NumT T) - -> EventG NumT T) - , 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) - ]) - ] - ) - -monoid_E :: TestBatch -monoid_E = monoid (undefined :: EventG NumT T) - - --- 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, Bounded t, Ord t', Bounded t') - => String -> (EventG t a -> EventG t' a') - -> (String,Property) -monotonicity n f = (n, property $ monotoneTest f) - -monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t - ,Num t, Ord t, Bounded t, Ord t', Bounded t') - => String -> (b -> EventG t a -> EventG t' a') - -> (String,Property) -monotonicity2 n f = (n, property $ monotoneTest2 f) - -monotoneTest :: (Ord t', Bounded t') => - (EventG t a -> EventG t' a') - -> EventG t a - -> Bool -monotoneTest f e = unsafePerformIO ( (evaluate (isMonotoneE . f $ e)) - `race` slowTrue) - -monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t - ,Num t, Ord t, Bounded t, Ord t', Bounded 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, Bounded t) => EventG t a -> Bool -isMonotoneE = liftA2 (||) isNeverE - ((uncurry isMonotoneR') . unFuture . eFuture) - -isMonotoneE' :: (Ord t, Bounded t) => (Time t) -> EventG t a -> Bool -isMonotoneE' t = - liftA2 (||) isNeverE - ((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture) - -isMonotoneR :: (Ord t, Bounded t) => ReactiveG t a -> Bool -isMonotoneR (_ `Stepper` e) = isMonotoneE e - -isMonotoneR' :: (Ord t, Bounded t) => Time t -> ReactiveG t a -> Bool -isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e - -simulEventOrder :: ( Arbitrary t, Num t, Ord t, Bounded t - , Arbitrary t', Num t', Ord t', Bounded t' - , Num t'', Ord t'', Bounded t'' - , Num t''', Ord t''', Bounded t''') - => String -> (EventG t t' -> EventG t'' t''') - -> (String, Property) -simulEventOrder n f = - (n,forAll genEvent (isStillOrderedE . f)) - where - genEvent :: ( Arbitrary t1, Num t1, Ord t1, Bounded t1 - , Arbitrary t2, Num t2, Ord t2, Bounded t2) - => Gen (EventG t1 t2) - genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing - increasing) - isStillOrderedE :: ( Num t1, Ord t1, Bounded t1 - , Num t2, Ord t2, Bounded t2) => EventG t1 t2 -> Bool - isStillOrderedE = - liftA2 (||) isNeverE - (isStillOrderedR . futVal . eFuture) - - isStillOrderedR (a `Stepper` e) = - isStillOrderedE' a e - - isStillOrderedE' a = - liftA2 (||) isNeverE - (isStillOrderedR' a . futVal . eFuture) - - isStillOrderedR' a (b `Stepper` e) = - a < b && isStillOrderedE' b e - --- An infinite event. handy for testing. -infE :: EventG NumT NumT -infE = futuresE (zipWith future [1..] [1..]) - diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs deleted file mode 100755 index 57868f7..0000000 --- a/src/FRP/Reactive/Reactive.hs +++ /dev/null @@ -1,390 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, TypeOperators - , FlexibleInstances, TypeFamilies - #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FRP.Reactive.Reactive --- Copyright : (c) Conal Elliott 2008 --- License : GNU AGPLv3 (see COPYING) --- --- 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 - , ImpBounds, exactNB, {-TimeFinite,-} TimeT, ITime, Future - , traceF - -- * Event - , Event - , withTimeE, withTimeE_ - , atTime, atTimes, listE - , {-mbsEvent,-} zipE, scanlE, monoidE - , firstRestE, firstE, restE - , remainderR, snapRemainderE, onceRestE - , withPrevE, withPrevEWith, withNextE, withNextEWith - , mealy, mealy_, countE, countE_, diffE - -- * Reactive values - , Reactive - , 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 -import Data.AffineSpace - --- TypeCompose -import Data.Zip (pairEdit) - -import Data.Max -import Data.AddBounds -import FRP.Reactive.Future hiding (batch) -import FRP.Reactive.PrimReactive hiding (batch) -import FRP.Reactive.Improving hiding (batch) - --- -- | The type of finite time values --- type TimeFinite = Double - --- | The type of time values with additional min & max elements. -type TimeT = Double --- type TimeT = AddBounds TimeFinite - -type ImpBounds t = Improving (AddBounds t) - --- | Exact & finite content of an 'ImpBounds' -exactNB :: ImpBounds t -> t -exactNB = unNo . exact - where - unNo (NoBound t) = t - unNo _ = error "exactNB: unNo on MinBound or maxBound" - --- TODO: when I switch to relative time, I won't need MinBound, so --- introduce a HasInfinity class and use infinity in place of maxBound - --- | Improving times, as used for time values in 'Event', 'Reactive', --- and 'ReactiveB'. -type ITime = ImpBounds TimeT - --- 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 :: Ord t => - EventG (ImpBounds t) d -> EventG (ImpBounds t) (d, t) -withTimeE e = second (exactNB.timeT) <$> withTimeGE e - --- | Access occurrence times in an event. Discard the rest. See also --- 'withTimeE'. --- --- > withTimeE_ :: Event a -> Event TimeT -withTimeE_ :: Ord t => - EventG (ImpBounds t) d -> EventG (ImpBounds t) t -withTimeE_ = (result.fmap) snd withTimeE - -timeT :: Ord t => Time t -> t -timeT (Max t) = t - --- timeT (Max (NoBound t)) = t --- timeT _ = error "timeT: non-finite time" - --- | Single-occurrence event at given time. See 'atTimes' and 'atTimeG'. -atTime :: TimeT -> Event () -atTime = atTimes . pure - --- atTime = atTimeG . exactly . NoBound - --- | Event occuring at given times. See also 'atTime' and 'atTimeG'. -atTimes :: [TimeT] -> Event () -atTimes = atTimesG . fmap (exactly . NoBound) - - --- | Convert a temporally monotonic list of timed values to an event. See also --- the generalization 'listEG' -listE :: [(TimeT,a)] -> Event a -listE = listEG . fmap (first (exactly . NoBound)) - --- | Generate a pair-valued event, given a pair of initial values and a --- pair of events. See also 'pair' on 'Reactive'. Not quite a 'zip', --- because of the initial pair required. -zipE :: (Ord t, Bounded t) => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d) -zipE cd cde = cd `accumE` pairEdit cde - --- | Like 'scanl' for events. -scanlE :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> EventG t a -scanlE f a e = a `accumE` (flip f <$> e) - --- | Accumulate values from a monoid-typed event. Specialization of --- 'scanlE', using 'mappend' and 'mempty'. -monoidE :: (Ord t, Bounded t, Monoid o) => EventG t o -> EventG t o -monoidE = scanlE mappend mempty - - - --- | Decompose an event into its first occurrence value and a remainder --- event. See also 'firstE' and 'restE'. -firstRestE :: (Ord t, Bounded t) => EventG t a -> (a, EventG t a) -firstRestE = futVal . eventOcc - --- | Extract the first occurrence value of an event. See also --- 'firstRestE' and 'restE'. -firstE :: (Ord t, Bounded t) => EventG t a -> a -firstE = fst . firstRestE - --- | Extract the remainder an event, after its first occurrence. See also --- 'firstRestE' and 'firstE'. -restE :: (Ord t, Bounded t) => EventG t a -> EventG t a -restE = snd . firstRestE - - - --- | Remaining part of an event. See also 'withRestE'. -remainderR :: (Ord t, Bounded t) => EventG t a -> ReactiveG t (EventG t a) -remainderR e = e `stepper` (snd <$> withRestE e) - - --- | Tack remainders a second event onto values of a first event. Occurs --- when the first event occurs. -snapRemainderE :: (Ord t, Bounded t) => - EventG t b -> EventG t a -> EventG t (a, EventG t b) -snapRemainderE = snapshot . remainderR - --- snapRemainderE eb = snapshot (remainderR eb) - --- eb `snapRemainderE` ea = remainderR eb `snapshot` ea - --- withTailE ea eb = error "withTailE: undefined" ea eb - - --- | Convert an event into a single-occurrence event, whose occurrence --- contains the remainder. -onceRestE :: (Ord t, Bounded t) => EventG t a -> EventG t (a, EventG t a) -onceRestE = once . withRestE - - - --- | 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, Bounded t) => EventG t a -> EventG t (a,a) -withPrevE e = (joinMaybes . fmap combineMaybes) $ - (Nothing,Nothing) `accumE` fmap (shift.Just) e - where - -- Shift newer value into (new,old) pair if present. - shift :: u -> (u,u) -> (u,u) - shift newer (new,_) = (newer,new) - combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v) - combineMaybes = uncurry (liftA2 (,)) - - --- | Same as 'withPrevE', but allow a function to combine the values. --- Provided for convenience. -withPrevEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b -withPrevEWith f e = fmap (uncurry f) (withPrevE e) - - --- | Pair each event value with the next one one. The second result is --- the next one. -withNextE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a) -withNextE = (result.fmap.second) firstE withRestE --- Alt. def. --- withNextE = fmap (second firstE) . withRestE - --- | Same as 'withNextE', but allow a function to combine the values. --- Provided for convenience. -withNextEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b -withNextEWith f e = fmap (uncurry f) (withNextE e) - - --- | Mealy-style state machine, given initial value and transition --- function. Carries along event data. See also 'mealy_'. -mealy :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t (b,s) -mealy s0 f = scanlE h (b0,s0) - where - b0 = error "mealy: no initial value" - h (_,s) b = (b, f s) - --- | Mealy-style state machine, given initial value and transition --- function. Forgetful version of 'mealy'. -mealy_ :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t s -mealy_ = (result.result.result.fmap) snd mealy - --- mealy_ s0 f e = snd <$> mealy s0 f e - - --- | Count occurrences of an event, remembering the occurrence values. --- See also 'countE_'. -countE :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t (b,n) -countE = mealy 0 (+1) - --- | Count occurrences of an event, forgetting the occurrence values. See --- also 'countE'. -countE_ :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t n -countE_ = (result.fmap) snd countE - --- countE_ e = snd <$> countE e - --- | Difference of successive event occurrences. See 'withPrevE' for a --- trick to supply an initial previous value. -diffE :: (Ord t, Bounded t, AffineSpace a) => - EventG t a -> EventG t (Diff a) -diffE = withPrevEWith (.-.) - --- -- | Returns an event whose occurrence's value corresponds with the input --- -- event's previous occurence's value. --- 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, Bounded t) => ReactiveG t b -> EventG t a -> EventG t (a,b) -snapshot = snapshotWith (,) - --- | Like 'snapshot' but discarding event data (often @a@ is '()'). -snapshot_ :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t b -snapshot_ = snapshotWith (flip const) - --- Alternative implementations --- e `snapshot_` src = snd <$> (e `snapshot` src) --- snapshot_ = (result.result.fmap) snd snapshot - --- | Filter an event according to whether a reactive boolean is true. -whenE :: (Ord t, Bounded t) => EventG t a -> ReactiveG t Bool -> EventG t a -whenE e = joinMaybes . fmap h . flip snapshot e - where - h (a,True) = Just a - h (_,False) = Nothing - --- | Like 'scanl' for reactive values. See also 'scanlE'. -scanlR :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a -scanlR f a e = a `stepper` scanlE f a e - --- | Accumulate values from a monoid-valued event. Specialization of --- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'. -monoidR :: (Ord t, Bounded t, Monoid a) => EventG t a -> ReactiveG t a -monoidR = scanlR mappend mempty - --- Equivalently, --- monoidR = stepper mempty . monoidE - --- | Combine two events into one. -eitherE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t (Either a b) -eitherE ea eb = ((Left <$> ea) `mappend` (Right <$> eb)) - --- | Start out blank ('Nothing'), latching onto each new @a@, and blanking --- on each @b@. If you just want to latch and not blank, then use --- 'mempty' for @lose@. -maybeR :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t (Maybe a) -maybeR get lose = - Nothing `stepper` ((Just <$> get) `mappend` (Nothing <$ lose)) - --- | Flip-flopping reactive value. Turns true when @ea@ occurs and false --- when @eb@ occurs. -flipFlop :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t Bool -flipFlop ea eb = - False `stepper` ((True <$ ea) `mappend` (False <$ eb)) - --- TODO: redefine maybeR and flipFlop in terms of eitherE. - --- | Count occurrences of an event. See also 'countE'. -countR :: (Ord t, Bounded t, Num n) => EventG t a -> ReactiveG t n -countR e = 0 `stepper` countE_ e - --- | Partition an event into segments. -splitE :: (Ord t, Bounded t) => EventG t b -> EventG t a -> EventG t (a, EventG t b) -eb `splitE` ea = h <$> (eb `snapRemainderE` withRestE ea) - where - h ((a,ea'),eb') = (a, eb' `untilE` ea') - --- | Switch from one event to another, as they occur. (Doesn't merge, as --- 'join' does.) -switchE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a -switchE = join . fmap (uncurry untilE) . withRestE - - --- | Euler integral. -integral :: forall v t. (VectorSpace v, AffineSpace t, Scalar v ~ Diff t) => - t -> Event t -> Reactive v -> Reactive v -integral t0 newT r = sumR (snapshotWith (*^) r deltaT) - where - deltaT :: Event (Diff t) - deltaT = diffE (pure t0 `mappend` newT) - --- TODO: find out whether this integral works recursively. If not, then --- fix the implementation, rather than changing the semantics. (No --- "delayed integral".) - -sumR :: (Ord t, Bounded t) => AdditiveGroup v => EventG t v -> ReactiveG t 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 deleted file mode 100755 index dedb830..0000000 --- a/src/FRP/Reactive/SImproving.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# 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 deleted file mode 100755 index e3e8ec4..0000000 --- a/src/FRP/Reactive/Sorted.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# 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 deleted file mode 100755 index 5fb9792..0000000 --- a/src/FRP/Reactive/VectorSpace.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances - , TypeFamilies - #-} - -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - -module FRP.Reactive.VectorSpace( ) where - -import FRP.Reactive.Behavior -import Control.Applicative - -import Data.VectorSpace - -instance AdditiveGroup v => AdditiveGroup (Behavior v) where - zeroV = pure zeroV - (^+^) = liftA2 (^+^) - negateV = liftA negateV - -instance VectorSpace v => VectorSpace (Behavior v) where - type Scalar (Behavior v) = Scalar v - (*^) s = fmap (s *^) diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100755 index 729a16d..0000000 --- a/src/Test.hs +++ /dev/null @@ -1,3 +0,0 @@ --- Run tests. ghc --make Test.hs -o test -threaded ; ./test - -import Test.Reactive diff --git a/src/Test/Integ.hs b/src/Test/Integ.hs deleted file mode 100755 index 2d3997c..0000000 --- a/src/Test/Integ.hs +++ /dev/null @@ -1,52 +0,0 @@ --- Simple test of recursive integrals, from Beelsebob - -import Control.Arrow (first) - -import Data.Max -import Data.AddBounds -import FRP.Reactive.Behavior -import FRP.Reactive.PrimReactive -import FRP.Reactive.Internal.Reactive -import FRP.Reactive.Internal.Behavior -import FRP.Reactive.Future -import FRP.Reactive -import FRP.Reactive.Improving - - --- For ticker -import FRP.Reactive.Internal.Clock -import FRP.Reactive.Internal.TVal -import System.IO.Unsafe - - -tick = atTimes [0,0.01 .. 2] -it = integral tick - -ib = 1 + it ib :: Behavior Double -e' = atTimes [0,0.1 .. 1.1] - --- [(0.0,1.0),(0.1,1.1046221254112045),(0.2,1.2081089504435316),(0.30000000000000004,1.3345038765672335),(0.4000000000000001,1.4741225085031893),(0.5000000000000001,1.6283483384592894),(0.6000000000000001,1.7987096025387035),(0.7000000000000001,1.9868944241538458),(0.8,2.1947675417764927),(0.9,2.424388786780674),(1.0,2.67803349447676),(1.1,2.7048138294215276)] - -i1 = occs (ib `snapshot_` e') - -itst b = occs (it b `snapshot_` e') - -occs :: Event a -> [(TimeT, a)] -occs = map (first (unNo . exact . getMax) . unFuture) . eFutures - where - unNo (NoBound a) = a - --- [(0.0,0.0),(0.1,9.999999999999996e-2),(0.2,0.19),(0.30000000000000004,0.2900000000000001),(0.4000000000000001,0.3900000000000002),(0.5000000000000001,0.49000000000000027),(0.6000000000000001,0.5900000000000003),(0.7000000000000001,0.6900000000000004),(0.8,0.7900000000000005),(0.9,0.8900000000000006),(1.0,0.9900000000000007),(1.1,1.0000000000000007)] - -i2 = itst 1 - --- K 0.0 `Stepper` (1.0e-2,K 1.0e-2)->(2.0e-2,K 2.0e-2)->(3.0e-2,K 3.0e-2)->(3.9999999999999994e-2,K 3.9999999999999994e-2)->(4.999999999999999e-2,K 4.999999999999999e-2)->(5.9999999999999984e-2,K 5.9999999999999984e-2)->(6.999999999999998e-2,K 6.999999999999998e-2)->(7.999999999999997e-2,K 7.999999999999997e-2)->(8.999999999999997e-2,K 8.999999999999997e-2)->(9.999999999999996e-2,K 9.999999999999996e-2)->(0.10999999999999996,K 0.10999999999999996)->(0.11999999999999995,K 0.11999999999999995)->(0.12999999999999995,K 0.12999999999999995)->(0.13999999999999996,K 0.13999999999999996)->(0.14999999999999997,K 0.14999999999999997)->(0.15999999999999998,K 0.15999999999999998)->(0.16999999999999998,K 0.16999999999999998)->(0.18,K 0.18)->(0.19,K 0.19)->(0.2,K 0.2)-> ... - -r2 = unb (it 1) - -main = print i1 - --- Integration seems much slower than i'd expect it to be, even in the --- non-recursive case. Recursive and non-recursive examples slow down as --- they go. - diff --git a/src/Test/Merge.hs b/src/Test/Merge.hs deleted file mode 100755 index c3b76e0..0000000 --- a/src/Test/Merge.hs +++ /dev/null @@ -1,89 +0,0 @@ --- Tracking down a problem with event merging - -import Data.Monoid (mappend) -import Control.Applicative ((<$>)) - -import FRP.Reactive.Improving -import FRP.Reactive.Future -import FRP.Reactive.PrimReactive -import FRP.Reactive.Reactive -import FRP.Reactive.Internal.Future -import FRP.Reactive.Internal.Reactive - - --- (Imp 1.0,1)->(Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined -e1 = listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)] - --- (Imp 1.5,100)->(Imp 2.5,200) -e2 = listEG [(exactly 1.5, 100), (exactly 2.5, 200)] - --- (Imp *** Exception: Prelude.undefined -e3 = listEG [(after 2.5, 200)] - --- (Imp 1.5,100)->(Imp 2.3,200)->(Imp *** Exception: Prelude.undefined -e3' = listEG [(exactly 1.5, 100), (exactly 2.3, 200), (after 2.5, 300)] - --- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.5,200)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined -e4 = e1 `mappend` e2 - --- (Imp 1.0,1)->(Imp 2.0,2)<interactive>: after: comparing after -e5 = e1 `mappend` e3 - --- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.3,200)<interactive>: after: comparing after -e5' = e1 `mappend` e3' - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined -f1 = eFuture e1 - --- <NoBound Imp 1.5,100 `Stepper` (Imp 2.5,200)> -f2 = eFuture e2 - --- <NoBound Imp *** Exception: Prelude.undefined -f3 = eFuture e3 - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined -f4 = f1 `mappend` f3 - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after -f5 = f1 `merge` f3 - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after -f5' = eFuture e5 - - - --- - -type Binop a = a -> a -> a - -mergeLR, mergeL, mergeR :: (Ord s) => Binop (FutureG s (ReactiveG s b)) - --- Same as 'merge' -u `mergeLR` v = - (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) - -u `mergeL` v = inFutR (`merge` v) <$> u - -u `mergeR` v = inFutR (u `merge`) <$> v - --- inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b)) --- -> (ReactiveG s b -> ReactiveG t b) - - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after -f6 = f1 `mergeLR` f3 - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after -f7 :: Future (Reactive Integer) -f7 = f1 `mergeL` f3 - --- <NoBound Imp *** Exception: Prelude.undefined -f8 = f1 `mergeR` f3 - - -f7' :: Future (Reactive Integer) - --- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after -f7' = q <$> f1 - where - q (a `Stepper` Event u') = a `Stepper` Event (u' `merge` f3) diff --git a/src/Test/Reactive.hs b/src/Test/Reactive.hs deleted file mode 100755 index 53c3f93..0000000 --- a/src/Test/Reactive.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# 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 - -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 diff --git a/src/Test/SimpleFilter.hs b/src/Test/SimpleFilter.hs deleted file mode 100755 index a3ec25e..0000000 --- a/src/Test/SimpleFilter.hs +++ /dev/null @@ -1,92 +0,0 @@ --- Tracking down a problem with event merging - -import Data.Monoid -import Control.Applicative (pure,(<$>)) -import Control.Monad (join) - -import Data.Unamb - -import Data.Max -import Data.AddBounds -import FRP.Reactive.Improving -import FRP.Reactive.Future -import FRP.Reactive.PrimReactive -- hiding (filterE) -import FRP.Reactive.Reactive -- hiding (filterE) -import FRP.Reactive.Internal.Future -import FRP.Reactive.Internal.Reactive - --- For neverE -import FRP.Reactive.Internal.Clock -import FRP.Reactive.Internal.TVal -import System.IO.Unsafe - - -negateOdds :: Event Int -> Event Int -negateOdds e = - (negate <$> filterE odd e) `mappend` (filterE even e) - -en :: TimeT -> Improving (AddBounds TimeT) -en = exactly . NoBound - -an :: TimeT -> Improving (AddBounds TimeT) -an = after . NoBound - -t :: (Bounded t, Eq t) => Int -> EventG t a -> [FutureG t a] -t n = take n . eFutures - -e7 :: Event Int -e7 = listEG [(en 1,1),(en 2,2),(en 3,3),(an 4,17)] -t7 = t 3 e7 - -e8 = filterE odd e7 -t8 = t 2 e8 - -e9 = negate <$> e8 -t9 = t 2 e9 - -e10 = filterE even e7 -t10 = t 1 e10 - -e11 = e9 `mappend` e10 -t11 = t 3 e11 - -e12 = filterE (const True) e7 -t12 = t 3 e12 - -e13 = filterE (const True) e7 `mappend` mempty -t13 = t 3 e13 - -e14 = filterE (const True) e7 `mappend` listEG [(an 5, error "five")] -t14 = t 3 e14 - --- One occurrence out per second -e15 = filterE (const True) e7 `mappend` neverE -t15 = t 3 e15 - --- This one finishes fine. -e16 = filterE (const True) e7 `mappend` listEG [(maxBound, error "maxed out")] -t16 = t 3 e16 - -e17 = e7 `mappend` neverE -t17 = t 3 e17 - - --- Semantically equivalent to mappend -neverE :: Event a -neverE = unsafePerformIO $ - do c <- makeClock - (_,never) <- makeEvent c - return never - --- as expected: [<Imp NoBound C-c C-c -tN = t 1 neverE - --- Imp NoBound C-c C-c -tinf :: ITime -tinf = getMax (futTime (head tN)) - --- True -p1 = en 0 <= tinf - --- GT -p2 = compareI tinf (NoBound 0) diff --git a/src/Test/Snap.hs b/src/Test/Snap.hs deleted file mode 100755 index 189c95f..0000000 --- a/src/Test/Snap.hs +++ /dev/null @@ -1,28 +0,0 @@ --- From Beelsebob's: http://hpaste.org/13096 - --- *FRP.Reactive.Behavior FRP.Reactive.Reactive FRP.Reactive.Improving FRP.Reactive.Fun FRP.Reactive.Internal.Fun> paddlePosR --- 0.0 `Stepper` (1.0,5.0e-2)->(2.0,0.0)->(3.0,5.0e-2)->(*** Exception: Prelude.undefined --- *FRP.Reactive.Behavior FRP.Reactive.Reactive FRP.Reactive.Improving FRP.Reactive.Fun FRP.Reactive.Internal.Fun> paddlePosR `FRP.Reactive.Reactive.snapshot_` (listEG [(exactly (2.5 :: TimeT), ()),(exactly 3.5, ())]) --- (2.5,0.0)->(3.5,0.0) - --- I was unable to reproduce the error: - -import FRP.Reactive.Improving -import FRP.Reactive.PrimReactive -import FRP.Reactive.Reactive - -r :: Reactive Int -r = 0 `stepper` listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)] - -e :: Event () -e = listEG [(exactly 2.5, ()),(exactly 3.5, ())] - -e1 :: Event Int -e1 = r `snapshot_` e - --- (Imp 2.5,2)->(Imp 3.5,3) - -e2 :: EventG ITime (Maybe (), Int) -e2 = r `snap` e - --- (Imp 1.0,(Nothing,1))->(Imp 2.0,(Nothing,2))->(Imp 2.5,(Just (),2))->(Imp 3.0,(Nothing,3))->(Imp 3.5,(Just (),3))->(Imp *** Exception: Prelude.undefined |