packages feed

reactive 0.3 → 0.5

raw patch · 14 files changed

+900/−26 lines, 14 filesdep ~TypeCompose

Dependency ranges changed: TypeCompose

Files

changes.tw view
@@ -1,5 +1,22 @@ == Version 0 == +=== Version 0.5 ===++Experiments toward a radically new implementation.  Active code is unaffected.  (I hope!)++* commented out experimental modules (breaking TypeCompose 0.4 DistribM dependency)+* new Improving.hs (old is SImproving.hs), Unamb.+* Generalized Reactive to Reactive'+* structural tweaking with EventExtras+* factored out EventExtras for use with different Events reps.+* many additions to SReactive+* SFuture tweak.  redid mergeF in SEvent.+* Data.SReactive+* Event' in event ops in MEvent.hs+* MEvent.hs: more event ops+* lots of little experiments+* race condition fixed in the race function in Data.Future+ === Version 0.3 ===  * Commented out LANGUAGE pragmas and added OPTIONS_GHC -fglasgow-exts for ghc-6.6 compatibility.
reactive.cabal view
@@ -1,5 +1,5 @@ Name:                reactive-Version:             0.3+Version:             0.5 Synopsis: 	     Simple foundation for functional reactive programming Category:            reactivity, FRP Description:@@ -23,13 +23,20 @@ Copyright:           (c) 2007-2008 by Conal Elliott License:             BSD3 Stability:           provisional+build-type:	     Simple Hs-Source-Dirs:      src Extensions:          -Build-Depends:       base, TypeCompose+Build-Depends:       base, TypeCompose>=0.3 Exposed-Modules:      		     Data.SFuture 		     Data.Future 		     Data.Fun 		     Data.Reactive Extra-Source-Files:-ghc-options:         -Wall -O+ghc-options:         -Wall++-- Experimental modules:+-- 		     Data.SEvent+-- 		     Data.MEvent+-- 		     Data.EventExtras+-- 		     Data.SReactive
+ src/Data/EventExtras.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.EventExtras+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Event "extras", i.e., independent of representation+----------------------------------------------------------------------++module Data.EventExtras+  (+    module Data.SEvent+    -- * Event extras+  , EventD, EventI+  , traceE, pairE, scanlE, monoidE+  , withPrevE, countE, countE_, diffE+    -- * To be moved elsewhere+  , joinMaybes, filterMP+  ) where++import Control.Monad (liftM)+import Control.Applicative ((<$>),liftA2)+import Data.Pair (pairEdit)+import Data.Monoid+import Control.Monad (MonadPlus(..))+import Debug.Trace (trace)++import Data.SEvent+-- import Data.MEvent++import Data.Improving++-- | Event, using Double for time+type EventD = Event' Double++-- | Event, using an /improving/ double for time+type EventI = Event' (Improving Double)++-- | Tracing of events.+traceE :: (a -> String) -> Event' t a -> Event' t a+traceE shw = fmap (\ a -> trace (shw a) a)++pairE :: Ord t => (c,d) -> (Event' t c, Event' t d) -> Event' t (c,d)+pairE cd cde = cd `accumE` pairEdit cde++-- | Like 'scanl' for events.  See also 'scanlR'.+scanlE :: Ord t => (a -> b -> a) -> a -> Event' t b -> Event' t a+scanlE f a e = a `accumE` (flip f <$> e)++-- | Accumulate values from a monoid-valued event.  Specialization of+-- 'scanlE', using 'mappend' and 'mempty'.  See also 'monoidR'.+monoidE :: (Ord t, Monoid o) => Event' t o -> Event' t o+monoidE = scanlE mappend mempty++-- | Pair each event value with the previous one, given an initial value.+withPrevE :: Ord t => Event' t a -> Event' t (a,a)+withPrevE e = (joinMaybes . fmap combineMaybes) $+              (Nothing,Nothing) `accumE` fmap (shift.Just) e+ where+   -- Shift newer value into (old,new) pair if present.+   shift :: u -> (u,u) -> (u,u)+   shift new (_,old) = (old,new)+   combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)+   combineMaybes = uncurry (liftA2 (,))++-- | Count occurrences of an event, remembering the occurrence values.+-- See also 'countE_'.+countE :: (Ord t, Num n) => Event' t b -> Event' t (b,n)+countE = scanlE h (b0,0)+ where+   b0        = error "withCountE: no initial value"+   h (_,n) b = (b,n+1)++-- | Count occurrences of an event, forgetting the occurrence values.  See+-- also 'countE'.  See also 'countR'.+countE_ :: (Ord t, Num n) => Event' t b -> Event' t n+countE_ e = snd <$> countE e++-- | Difference of successive event occurrences.+diffE :: (Ord t, Num n) => Event' t n -> Event' t n+diffE e = uncurry (-) <$> withPrevE e+++{--------------------------------------------------------------------+    To be moved elsewhere+--------------------------------------------------------------------}++-- | Pass through @Just@ occurrences.+joinMaybes :: MonadPlus m => m (Maybe a) -> m a+joinMaybes = (>>= maybe mzero return)++-- | Pass through values satisfying @p@.+filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a+filterMP p m = joinMaybes (liftM f m)+ where+   f a | p a       = Just a+       | otherwise = Nothing++-- Alternatively:+-- filterMP p m = m >>= guarded p+--  where+--    guarded p x = guard (p x) >> return x+
src/Data/Fun.hs view
@@ -13,6 +13,7 @@  module Data.Fun (Fun(..), apply) where +import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..)) import Control.Arrow hiding (pure) @@ -24,6 +25,11 @@ 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)
src/Data/Future.hs view
@@ -1,7 +1,6 @@ -- {-# LANGUAGE RecursiveDo #-} -- For ghc-6.6 compatibility {-# OPTIONS_GHC -fglasgow-exts #-}-{-# OPTIONS -fno-warn-orphans #-}  ---------------------------------------------------------------------- -- |@@ -152,7 +151,9 @@ 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@@ -168,4 +169,3 @@ -- | Run an 'IO'-action-valued 'Future'. runFuture :: Future (IO ()) -> IO () runFuture = join . force-
+ src/Data/Improving.hs view
@@ -0,0 +1,53 @@+----------------------------------------------------------------------+-- |+-- Module      :  Data.Improving+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Improving values -- efficient version+----------------------------------------------------------------------++module Data.Improving+  (+    Improving(..), minI+  ) where+++import Data.Unamb (unamb,assuming)++{----------------------------------------------------------+    Improving values+----------------------------------------------------------}++-- | An improving value.+data Improving a = IV a (a -> Ordering)++-- | A known improving value (which doesn't really improve)+exactly :: Ord a => a -> Improving a+exactly a = IV a (compare a)++instance Eq a => Eq (Improving a) where+  IV a _ == IV b _ = a == b++instance Ord a => Ord (Improving a) where+  s `min` t = fst (s `minI` t)+  s  <=   t = snd (s `minI` t)++-- | Efficient combination of 'min' and '(<=)'+minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)+IV u uComp `minI` IV v vComp = (IV uMinV wComp, uLeqV)+ where+   uMinV = if uLeqV then u else v+   -- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@.+   uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT)+   -- (u `min` v) `compare` t: Try comparing according to whether u <= v,+   -- or go with either answer if they agree, e.g., if both say GT.+   minComp = if uLeqV then uComp else vComp+   wComp t = minComp t `unamb`+	     assuming (uCompT == vCompT) uCompT+    where+       uCompT = uComp t+       vCompT = vComp t
+ src/Data/MEvent.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, MultiParamTypeClasses #-}++----------------------------------------------------------------------+-- |+-- Module      :  Data.MEvent+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Event implementation via semantics & Maybe+----------------------------------------------------------------------++module Data.MEvent+  (+    -- * Event primitives+    Event', accumE+  ) where++import Data.Monoid+import Data.Maybe+import Control.Monad (MonadPlus(..))++-- TypeCompose+import Control.Compose ((:.)(..),inO,inO2)++import qualified Data.SEvent as SR  -- semantics+++{----------------------------------------------------------+    Event primitives+----------------------------------------------------------}++-- | General events.  'Functor', 'Applicative', and 'Monoid' by+-- construction.  See also 'Event\''.+-- In this representation, an event is a list of time/maybe pairs.  The+-- 'Just's correspond to occurrences and the 'Nothing's to+-- non-occurrences.+type Event' t = SR.Event' t :. Maybe++-- The 'Monad' instance is thanks to Data.SEvent:+-- +--   instance Ord t => DistribM (Event' t) Maybe where ...++-- TODO: revisit Phooey.  Can I use :. in place of monad transformers?+-- How to monad transformers relate to the monad instance of (:.)?+-- Follow up on references from my chat with Cale on 2008-03-02.++-- One of the standard Monoid instances for type compositions.  This one+-- interleaves occurrences.+instance Ord t => Monoid (Event' t a) where+  mempty  = O mempty+  mappend = inO2 mappend  -- interleave++-- This MonadPlus instance could go in EventExtras, but it would be an+-- orphan there.+instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }+++-- | Accumulating event, starting from an initial value and a+-- update-function event.+accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a+accumE a = inO $ fmap Just . SR.accumE a . fmap (fromMaybe id)++-- TODO: redefine accumE to preserve 'Nothing's, for later optimization.++-- (<*>) :: Fut (a->a) -> Fut a -> Fut a++-- (<*>) (on futures) does some unnecessary work here, since the function+-- is guaranteed to be at least as new as the argument.
src/Data/Reactive.hs view
@@ -5,7 +5,6 @@ -- For ghc-6.6 compatibility {-# OPTIONS_GHC -fglasgow-exts #-} - ---------------------------------------------------------------------- -- | -- Module      :  Data.Reactive@@ -60,8 +59,10 @@ import Control.Monad import Debug.Trace (trace) import Data.IORef-import Control.Concurrent (forkIO,ThreadId)+import Control.Concurrent -- (forkIO,ThreadId) +import Data.Maybe+ -- TypeCompose import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..)) import Data.Pair@@ -99,7 +100,9 @@ -- 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/.+-- 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) } @@ -186,9 +189,18 @@  instance Applicative Reactive where   pure a = a `stepper` mempty-  rf@(f `Stepper` Event vf) <*> rx@(x `Stepper` Event vx) =-   f x `stepper` Event (((<*> rx) <$> vf) `mappend` ((rf <*>) <$> vx))+  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.@@ -281,7 +293,7 @@ accumE :: a -> Event (a -> a) -> Event a accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e' --- | Like 'scanl' for events.  See also 'scanE'.+-- | 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) @@ -373,11 +385,12 @@ 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'.+-- | 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 'scanE'.+-- | 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
+ src/Data/SEvent.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving+  , FlexibleInstances, FlexibleContexts, TypeSynonymInstances+  , MultiParamTypeClasses+  #-}++----------------------------------------------------------------------+-- |+-- Module      :  Data.SEvent+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Denotational semantics for events+----------------------------------------------------------------------++module Data.SEvent+  (+    -- * Event primitives+    Event'(..), accumE+  ) where++import Data.Monoid+import Control.Applicative+import Control.Monad++-- TypeCompose+import Control.Compose (Binop,DistribM(..))++import Data.SFuture+++{----------------------------------------------------------+    Event primitives+----------------------------------------------------------}++-- | Generalized 'Event' over arbitrary (ordered) time type.  See also+-- 'Event\''. +newtype Event' t a = E { unE :: [Future t a] }++-- | Apply a unary function within the 'Ascend' constructor.+inE :: ([Future t a] -> [Future t b]) -> (Event' t a -> Event' t b)+inE f = E . f . unE++-- | Apply a binary function within the 'E' constructor.+inE2 :: ([Future t a] -> [Future t b] -> [Future t c])+     -> (Event' t a -> Event' t b -> Event' t c)+inE2 f = inE . f . unE+++-- Note: the semantics of Applicative and Monad are not consistent with+-- +--   type Event = [] :. Fut+-- +-- because that composition would combine future values with []-style+-- backtracking instead of temporal interleaving.+-- +-- However, maybe there's a []-wrapping newtype I can use instead.++instance Ord t => Monoid (Event' t a) where+  mempty  = E []+  mappend = inE2 merge++instance Functor (Event' t) where+  fmap f = inE ((fmap.fmap) f)++instance Ord t => Applicative (Event' t) where+  pure  = return+  (<*>) = ap++instance Ord t => Monad (Event' t) where+  return a = E ((return.return) a)+  e >>= f  = joinE (f <$> e)++-- This MonadPlus instance could go in EventExtras, but it would be an+-- orphan there.+instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }++-- For monad compositions.+-- We'll need this instance in MEvent.  It'd be an orphan there.+instance Ord t => DistribM (Event' t) Maybe where+  -- distribM :: Maybe (Event' t b) -> Event' t (Maybe b)+  distribM = maybe mempty (fmap Just)++-- | Equivalent to 'join' for 'Event'.  More efficient?+joinE :: Ord t => Event' t (Event' t a) -> Event' t a+joinE = inE $ concatF . (fmap.fmap) unE++-- Derivation:+-- +--       Event (Event a) +--   --> [Fut (Event a)]  -- unE+--   --> [Fut [Fut a]]    -- (fmap.fmap) unE+--   --> [Fut a]          -- concatF+--   --> Event a          -- E++-- My previous attempt:++-- joinE :: Ord t => Event' t (Event' t a) -> Event' t a+-- joinE = mconcat . fmap (E . fmap join . sequenceF . fmap unE) . unE+--+-- Derivation:+-- +--       Event (Event a) +--   --> [Fut (Event a)]  -- unE+--   --> [Fut [Fut a]]    -- (fmap.fmap) unE+--   --> [[Fut (Fut a)]]  -- fmap sequenceF+--   --> [[Fut a]]        -- (fmap.fmap) join+--   --> [Event a]        -- fmap E+--   --> Event a          -- mconcat++-- I don't think joinE works as I want.  The join on Fut makes sure that+-- the inner occurrences follow the outer, but I don't think fact is+-- visible to the implementation.  Also, note that the mconcat could have+-- an infinite number of lists to merge.++flatFFs :: Ord t => Future t [Future t a] -> [Future t a]+flatFFs = fmap join . sequenceF++concatF :: Ord t => [Future t [Future t a]] -> [Future t a]+concatF = futVal . foldr mergeF (pure [])++-- Binary merge.  The second argument is required to have the property+-- that sub-futures are all at least as late as the containing future.+-- The result is then guaranteed to have the same property, which allows+-- use of futVal instead of flatFFs in concatF.+mergeF :: Ord t => Binop (Future t [Future t a])+ffa `mergeF` Future (tb,futbs) =+  -- First the a values before tb, then interleave the rest of the a+  -- values with the b values.  +  Future (futTime ffa, prefa ++ (suffa `merge` futbs))+ where+   (prefa,suffa) = span ((<= tb).futTime) (flatFFs ffa)++-- TODO: try out a more efficient version of mergeF that doesn't use+-- (++).  Idea: add a span to Data.DList and use it.  Efficient &+-- elegant.+++-- | Accumulating event, starting from an initial value and a+-- update-function event.  See also 'accumR'.+accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a+accumE a = inE $ \ futfs -> accum (pure a) (fmap (<*>) futfs)+++{--------------------------------------------------------------------+    Misc utilities+--------------------------------------------------------------------}++-- | Merge two ordered lists into an ordered list.+merge :: Ord a => [a] -> [a] -> [a]+[]         `merge` vs         = vs+us         `merge` []         = us+us@(u:us') `merge` vs@(v:vs') =+  if u <= v then+    u : (us' `merge` vs )+  else+    v : (us  `merge` vs')+++accum :: a -> [a->a] -> [a]+accum _ [] = []+accum a (f:fs) = a' : accum a' fs where a' = f a++-- or+--   accum a = tail . scanl (flip ($)) a
src/Data/SFuture.hs view
@@ -50,14 +50,28 @@ -- 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 where+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)+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@@ -70,24 +84,62 @@ -- | 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 (Time t, a)+newtype Future t a = Future { unFuture :: (Time t, a) }   deriving (Functor, Applicative, Monad, Show)  --  The 'Applicative' instance relies on the 'Monoid' instance of 'Max'. --- | Force a future.  The real version blocks until knowable.-force :: Future t a -> (Time t,a)-force (Future p) = p+-- | A future's time+futTime :: Future t a -> Time t+futTime = fst . unFuture --- The Monoid instance picks the earlier future+-- | 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")-  fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) =-    if t <= t' then fut else fut'+  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? --------- To go elsewhere+-- | 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'.@@ -115,8 +167,8 @@ -- 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+  return      = pure+  (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a  -- Alternatively, --   m >>= f = join (fmap f m)
+ src/Data/SImproving.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Improving+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy+-- in an Abstract Data Type with Deterministic Semantics\".+-- +-- TODO: an efficient, referentially transparent, side-effecting version.+----------------------------------------------------------------------++module Data.Improving+  (+    Improving(..), exact+  -- , Improves, merge+  -- , Future(..)+  ) where++import Data.Function (on)++-- | Progressive information about a value (e.g., a time)+data Improving t = AtLeast t (Improving t) | Exactly t deriving Show++-- | Extract an exact value from an improving value+exact :: Improving t -> t+exact (AtLeast _ u) = exact u+exact (Exactly t)   = t++instance Eq t => Eq (Improving t) where+  (==) = (==) `on` exact++instance Ord t => Ord (Improving t) where+  Exactly s `compare` Exactly t = s `compare` t+  AtLeast s u' `compare` v@(Exactly t) =+    if s > t then GT else u' `compare` v+  u@(Exactly s) `compare` AtLeast t v' =+    if s < t then LT else u  `compare` v'+  u@(AtLeast s u') `compare` v@(AtLeast t v') =+    -- move forward where we know less+    if s <= t then+      u' `compare` v+    else+      u  `compare` v'++  Exactly s `min` Exactly t = Exactly (s `min` t)+  AtLeast s u' `min` v@(Exactly t) =+    if s > t then v else u' `min` v+  u@(Exactly s) `min` AtLeast t v' =+    if s < t then u else u  `min` v'+  u@(AtLeast s u') `min` v@(AtLeast t v') =+    -- move forward where we know less+    if s <= t then+      u' `min` v+    else+      u  `min` v'
+ src/Data/SReactive.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.SReactive+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Simple, semantics-based reactive values+----------------------------------------------------------------------++module Data.SReactive+  (+    -- * Primitives+    Reactive'(..), stepper+  , joinR+    -- * Extras (defined via primitives)+  , Reactive+  , switcher, snapshot, snapshot_, whenE+  , accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR+  ) where++import Control.Applicative+import Control.Monad+import Data.Monoid++-- TypeCompose+import Control.Compose (Unop)+import Data.Pair (Pair(..),pairEdit)++import Data.EventExtras+import Data.Improving+++{----------------------------------------------------------+    Primitives+----------------------------------------------------------}++data Reactive' t a =+  Stepper {+    rInit  :: a                         -- ^ initial value+  , rEvent :: Event' t a                -- ^ waiting for event+  }++-- | Reactive value from an initial value and a new-value event.+stepper :: a -> Event' t a -> Reactive' t a+stepper = Stepper+++instance Ord t => Pair (Reactive' t) where+  -- pair :: Reactive' t a -> Reactive' t b -> Reactive' t (a,b)+  (c `Stepper` ce) `pair` (d `Stepper` de) =+    (c,d) `accumR` pairEdit (ce,de)++instance Functor (Reactive' t) where+  fmap f (a `Stepper` e) = f a `stepper` fmap f e++instance Ord t => Applicative (Reactive' t) where+  pure a = a `stepper` mempty+  -- Standard definition.  See 'Pair'.+  rf <*> rx = uncurry ($) <$> (rf `pair` rx)++-- A wonderful thing about the <*> definition for Reactive' t is that it+-- automatically caches the previous value of the function or argument+-- when the argument or function changes.++instance Ord t => Monad (Reactive' t) where+  return  = pure+  r >>= f = joinR (f <$> r)++-- | Reactive' t 'join' (equivalent to 'join' but slightly more efficient, I think)+joinR :: Ord t => Reactive' t (Reactive' t a) -> Reactive' t a+joinR ((a `Stepper` e) `Stepper` er) = +  a `stepper` (e `mappend` join (rToE <$> er))++-- | Turn a reactive value into an event, given a time for the initial+-- occurrence.+rToE :: Ord t => Reactive' t a -> Event' t a+rToE (a `Stepper` e) = pure a `mappend` e++-- e  :: Event' t a+-- er :: Event' t (Reactive' t a)+-- +-- rToE <$> er ::: Event' t (Event' t a)+-- join (rToE <$> er) ::: Event' t a++-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@+-- didn't.+snap :: forall a b t. Ord t =>+        Event' t a -> Reactive' t b -> Event' t (Maybe a, b)+ea `snap` (b0 `Stepper` eb) =+  (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)+ where+   fa :: a -> Unop (Maybe a, b)+   fb :: b -> Unop (Maybe a, b)+   fa a (_,b) = (Just a , b)+   fb b _     = (Nothing, b)+++{----------------------------------------------------------+    Extras (defined via primitives)+----------------------------------------------------------}++type Reactive = Reactive' (Improving Double)++-- | Snapshot a reactive value whenever an event occurs.+snapshot :: Ord t => Event' t a -> Reactive' t b -> Event' t (a,b)+e `snapshot` r = joinMaybes $ fmap f (e `snap` r)+ where+   f (Nothing,_) = Nothing+   f (Just a ,b) = Just (a,b)++-- | Switch between reactive values.+switcher :: Ord t => Reactive' t a -> Event' t (Reactive' t a) -> Reactive' t a+r `switcher` e = joinR (r `stepper` e)++-- | Like 'snapshot' but discarding event data (often @a@ is @()@).+snapshot_ :: Ord t => Event' t a -> Reactive' t b -> Event' t b+e `snapshot_` src = snd <$> (e `snapshot` src)++-- | Filter an event according to whether a boolean source is true.+whenE :: Ord t => Event' t a -> Reactive' t Bool -> Event' t a+whenE e = joinMaybes . fmap h . snapshot e+ where+   h (a,True)  = Just a+   h (_,False) = Nothing+++-- | Reactive' t value from an initial value and an updater event.  See also+-- 'accumE'.+accumR :: Ord t => a -> Event' t (a -> a) -> Reactive' t a+a `accumR` e = a `stepper` (a `accumE` e)++-- | Like 'scanl' for reactive values.  See also 'scanlE'.+scanlR :: Ord t => (a -> b -> a) -> a -> Event' t b -> Reactive' t a+scanlR f a e = a `stepper` scanlE f a e++-- | Accumulate values from a monoid-valued event.  Specialization of+-- 'scanlE', using 'mappend' and 'mempty'.  See also 'monoidE'.+monoidR :: (Ord t, Monoid a) => Event' t a -> Reactive' t a+monoidR = scanlR mappend mempty++-- | Start out blank ('Nothing'), latching onto each new @a@, and blanking+-- on each @b@.  If you just want to latch and not blank, then use+-- 'mempty' for @lose@.+maybeR :: Ord t => Event' t a -> Event' t b -> Reactive' t (Maybe a)+maybeR get lose =+  Nothing `stepper` (fmap Just get `mappend` (Nothing <$ lose))++-- | Flip-flopping source.  Turns true when @ea@ occurs and false when+-- @eb@ occurs.+flipFlop :: Ord t => Event' t a -> Event' t b -> Reactive' t Bool+flipFlop ea eb =+  False `stepper` ((True <$ ea) `mappend` (False <$ eb))++-- TODO: generalize 'maybeR' & 'flipFlop'.  Perhaps using 'Monoid'.+-- Note that Nothing and (Any False) are mempty.++-- | Count occurrences of an event.  See also 'countE'.+countR :: (Ord t, Num n) => Event' t a -> Reactive' t n+countR e = 0 `stepper` countE_ e++-- | Tracing of reactive values+traceR :: (a -> String) -> Unop (Reactive' t a)+traceR shw (a `Stepper` e) = a `Stepper` traceE shw e+
+ src/Data/Unamb.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecursiveDo #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Unamb+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Unambiguous choice+----------------------------------------------------------------------++module Data.Unamb+  (+    unamb, amb, race, assuming+  ) where++-- For hang+import Control.Monad (forever)+import System.IO.Unsafe++-- For unamb+import Control.Concurrent+import Control.Exception (evaluate)+++-- | Unambiguous choice operator.  Equivalent to the ambiguous choice+-- operator, but with arguments restricted to be equal where not bottom,+-- so that the choice doesn't matter.  See also 'amb'.+unamb :: a -> a -> a+a `unamb` b = unsafePerformIO (a `amb` b)+++-- | Ambiguous choice operator.  Yield either value.  Evaluates in+-- separate threads and picks whichever finishes first.  See also+-- 'unamb' and 'race'.+amb :: a -> a -> IO a+a `amb` b = evaluate a `race` evaluate b++-- | Race two actions against each other in separate threads, and pick+-- whichever finishes first.  See also 'amb'.+race :: IO a -> IO a -> IO a+a `race` b = +  -- Evaluate a and b in concurrent threads.  Whichever thread finishes+  -- first kill the other thread.+  do v    <- newEmptyMVar  -- to hold a or b+     lock <- newEmptyMVar  -- to avoid double-kill+     -- Evaluate one value and kill the other.+     let run io tid = forkIO $ do x <- io+                                  putMVar lock ()+                                  killThread tid+                                  putMVar v x+     mdo ta <- run a tb+         tb <- run b ta+         return ()+     readMVar v++-- Without using unsafePerformIO, is there a way to define a+-- non-terminating but non-erroring pure value that consume very little+-- resources while not terminating?++-- | Never yield an answer.  Like 'undefined' or 'error "whatever"', but+-- don't raise an error, and don't consume computational resources.+hang :: a+hang = unsafePerformIO hangIO++-- | Block forever+hangIO :: IO a+hangIO = do -- putStrLn "warning: blocking forever."+            -- Any never-terminating computation goes here+            -- This one can yield an exception "thread blocked indefinitely"+            -- newEmptyMVar >>= takeMVar+            -- sjanssen suggests this alternative:+            forever $ threadDelay maxBound+            -- forever's return type is (), though it could be fully+            -- polymorphic.  Until it's fixed, I need the following line.+            return undefined+++-- | Yield a value if a condition is true.  Otherwise wait forever.+assuming :: Bool -> a -> a+assuming c a = if c then a else hang
src/Examples.hs view
@@ -17,7 +17,7 @@ -- base import Data.Monoid import Data.IORef-import Control.Monad ((>=>),forM_)+import Control.Monad import Control.Applicative import Control.Arrow (first,second) import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId)@@ -242,3 +242,70 @@ -- 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)+