packages feed

reactive 0.5 → 0.5.0.1

raw patch · 15 files changed

+14/−1104 lines, 15 filesdep ~TypeComposedep ~basenew-uploader

Dependency ranges changed: TypeCompose, base

Files

− Makefile 
@@ -1,3 +0,0 @@-# For special configuration, especially for docs.  Otherwise see README.--include ../my-cabal-make.inc
− README 
@@ -1,31 +0,0 @@-_Reactive_ [1] is a simple foundation for programming reactive systems-functionally.  Like Fran/FRP, it has a notions of (reactive) behaviors and-events.  Like DataDriven [2], Reactive has a data-driven implementation.-The main difference between Reactive and DataDriven is that Reactive-builds on MVar-based "futures", while DataDriven builds on-continuation-based computations.--The inspiration for Reactive was Mike Sperber's Lula [3] implementation of-FRP.  Mike used blocking threads, which I had never considered for FRP.-While playing with the idea, I realized that I could give a very elegant-and efficient solution to caching, which DataDriven doesn't do.  (For an-application "f <*> a" of a varying function to a varying argument, caching-remembers the latest function to apply to a new argument and the last-argument to which to apply a new function.)--Please share any comments & suggestions on the discussion (talk) page-there.--You can configure, build, and install all in the usual way with Cabal-commands.--  runhaskell Setup.lhs configure-  runhaskell Setup.lhs build-  runhaskell Setup.lhs install---References:--[1] http://haskell.org/haskellwiki/Reactive-[2] http://haskell.org/haskellwiki/DataDriven-[3] http://www-pu.informatik.uni-tuebingen.de/lula/deutsch/publications.html
− changes.tw 
@@ -1,37 +0,0 @@-== 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.--=== Version 0.2 ===--* Fixed <hask>switcher</hask>.  Didn't terminate.  Thanks to Ivan Tomac for the bug report.--=== Version 0.1 ===--* Added <hask>Never</hask> constructor for Future.  Allows optimizations, including a huge improvement for <hask>(>>=)</hask> on <hask>Event</hask> (which had been piling up <hask>never</hask>s).-* removed <code>-threaded</code> comment-* added <hask>traceR</hask> (reactive value tracing)-* use idler in <code>src/Examples.hs</code> (for single-threaded use of wxHaskell)--=== Version 0.0 ===--* New project.
reactive.cabal view
@@ -1,5 +1,5 @@ Name:                reactive-Version:             0.5+Version:             0.5.0.1 Synopsis: 	     Simple foundation for functional reactive programming Category:            reactivity, FRP Description:@@ -26,7 +26,7 @@ build-type:	     Simple Hs-Source-Dirs:      src Extensions:          -Build-Depends:       base, TypeCompose>=0.3+Build-Depends:       base >= 3.0.3.2 && < 5, TypeCompose>=0.6.7 Exposed-Modules:      		     Data.SFuture 		     Data.Future
− src/Data/EventExtras.hs 
@@ -1,107 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-------------------------------------------------------------------------- |--- Module      :  Data.EventExtras--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Event "extras", i.e., independent of representation-------------------------------------------------------------------------module Data.EventExtras-  (-    module Data.SEvent-    -- * Event extras-  , EventD, EventI-  , traceE, pairE, scanlE, monoidE-  , withPrevE, countE, countE_, diffE-    -- * To be moved elsewhere-  , joinMaybes, filterMP-  ) where--import Control.Monad (liftM)-import Control.Applicative ((<$>),liftA2)-import Data.Pair (pairEdit)-import Data.Monoid-import Control.Monad (MonadPlus(..))-import Debug.Trace (trace)--import Data.SEvent--- import Data.MEvent--import Data.Improving---- | Event, using Double for time-type EventD = Event' Double---- | Event, using an /improving/ double for time-type EventI = Event' (Improving Double)---- | Tracing of events.-traceE :: (a -> String) -> Event' t a -> Event' t a-traceE shw = fmap (\ a -> trace (shw a) a)--pairE :: Ord t => (c,d) -> (Event' t c, Event' t d) -> Event' t (c,d)-pairE cd cde = cd `accumE` pairEdit cde---- | Like 'scanl' for events.  See also 'scanlR'.-scanlE :: Ord t => (a -> b -> a) -> a -> Event' t b -> Event' t a-scanlE f a e = a `accumE` (flip f <$> e)---- | Accumulate values from a monoid-valued event.  Specialization of--- 'scanlE', using 'mappend' and 'mempty'.  See also 'monoidR'.-monoidE :: (Ord t, Monoid o) => Event' t o -> Event' t o-monoidE = scanlE mappend mempty---- | Pair each event value with the previous one, given an initial value.-withPrevE :: Ord t => Event' t a -> Event' t (a,a)-withPrevE e = (joinMaybes . fmap combineMaybes) $-              (Nothing,Nothing) `accumE` fmap (shift.Just) e- where-   -- Shift newer value into (old,new) pair if present.-   shift :: u -> (u,u) -> (u,u)-   shift new (_,old) = (old,new)-   combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)-   combineMaybes = uncurry (liftA2 (,))---- | Count occurrences of an event, remembering the occurrence values.--- See also 'countE_'.-countE :: (Ord t, Num n) => Event' t b -> Event' t (b,n)-countE = scanlE h (b0,0)- where-   b0        = error "withCountE: no initial value"-   h (_,n) b = (b,n+1)---- | Count occurrences of an event, forgetting the occurrence values.  See--- also 'countE'.  See also 'countR'.-countE_ :: (Ord t, Num n) => Event' t b -> Event' t n-countE_ e = snd <$> countE e---- | Difference of successive event occurrences.-diffE :: (Ord t, Num n) => Event' t n -> Event' t n-diffE e = uncurry (-) <$> withPrevE e---{---------------------------------------------------------------------    To be moved elsewhere---------------------------------------------------------------------}---- | Pass through @Just@ occurrences.-joinMaybes :: MonadPlus m => m (Maybe a) -> m a-joinMaybes = (>>= maybe mzero return)---- | Pass through values satisfying @p@.-filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a-filterMP p m = joinMaybes (liftM f m)- where-   f a | p a       = Just a-       | otherwise = Nothing---- Alternatively:--- filterMP p m = m >>= guarded p---  where---    guarded p x = guard (p x) >> return x-
src/Data/Fun.hs view
@@ -15,7 +15,8 @@  import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..))-import Control.Arrow hiding (pure)+import qualified Control.Category (Category, (.), id)+import Control.Arrow (Arrow, arr, first, second, (***), (>>>))  -- | Constant-optimized functions data Fun t a = K a                      -- ^ constant function@@ -47,11 +48,14 @@   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-  _     >>> K b   = K   b-  K a   >>> Fun g = K   (g a)-  Fun g >>> Fun f = Fun (g >>> f)   first           = Fun . first  . apply   second          = Fun . second . apply   K a'  *** K b'  = K (a',b')
src/Data/Future.hs view
@@ -1,6 +1,6 @@--- {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RecursiveDo #-} -- For ghc-6.6 compatibility-{-# OPTIONS_GHC -fglasgow-exts #-}+-- {-# OPTIONS_GHC -fglasgow-exts #-}  ---------------------------------------------------------------------- -- |
− src/Data/Improving.hs 
@@ -1,53 +0,0 @@-------------------------------------------------------------------------- |--- Module      :  Data.Improving--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Improving values -- efficient version-------------------------------------------------------------------------module Data.Improving-  (-    Improving(..), minI-  ) where---import Data.Unamb (unamb,assuming)--{-----------------------------------------------------------    Improving values-----------------------------------------------------------}---- | An improving value.-data Improving a = IV a (a -> Ordering)---- | A known improving value (which doesn't really improve)-exactly :: Ord a => a -> Improving a-exactly a = IV a (compare a)--instance Eq a => Eq (Improving a) where-  IV a _ == IV b _ = a == b--instance Ord a => Ord (Improving a) where-  s `min` t = fst (s `minI` t)-  s  <=   t = snd (s `minI` t)---- | Efficient combination of 'min' and '(<=)'-minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)-IV u uComp `minI` IV v vComp = (IV uMinV wComp, uLeqV)- where-   uMinV = if uLeqV then u else v-   -- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@.-   uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT)-   -- (u `min` v) `compare` t: Try comparing according to whether u <= v,-   -- or go with either answer if they agree, e.g., if both say GT.-   minComp = if uLeqV then uComp else vComp-   wComp t = minComp t `unamb`-	     assuming (uCompT == vCompT) uCompT-    where-       uCompT = uComp t-       vCompT = vComp t
− src/Data/MEvent.hs 
@@ -1,72 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE TypeOperators, TypeSynonymInstances, MultiParamTypeClasses #-}--------------------------------------------------------------------------- |--- Module      :  Data.MEvent--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Event implementation via semantics & Maybe-------------------------------------------------------------------------module Data.MEvent-  (-    -- * Event primitives-    Event', accumE-  ) where--import Data.Monoid-import Data.Maybe-import Control.Monad (MonadPlus(..))---- TypeCompose-import Control.Compose ((:.)(..),inO,inO2)--import qualified Data.SEvent as SR  -- semantics---{-----------------------------------------------------------    Event primitives-----------------------------------------------------------}---- | General events.  'Functor', 'Applicative', and 'Monoid' by--- construction.  See also 'Event\''.--- In this representation, an event is a list of time/maybe pairs.  The--- 'Just's correspond to occurrences and the 'Nothing's to--- non-occurrences.-type Event' t = SR.Event' t :. Maybe---- The 'Monad' instance is thanks to Data.SEvent:--- ---   instance Ord t => DistribM (Event' t) Maybe where ...---- TODO: revisit Phooey.  Can I use :. in place of monad transformers?--- How to monad transformers relate to the monad instance of (:.)?--- Follow up on references from my chat with Cale on 2008-03-02.---- One of the standard Monoid instances for type compositions.  This one--- interleaves occurrences.-instance Ord t => Monoid (Event' t a) where-  mempty  = O mempty-  mappend = inO2 mappend  -- interleave---- This MonadPlus instance could go in EventExtras, but it would be an--- orphan there.-instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }----- | Accumulating event, starting from an initial value and a--- update-function event.-accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a-accumE a = inO $ fmap Just . SR.accumE a . fmap (fromMaybe id)---- TODO: redefine accumE to preserve 'Nothing's, for later optimization.---- (<*>) :: Fut (a->a) -> Fut a -> Fut a---- (<*>) (on futures) does some unnecessary work here, since the function--- is guaranteed to be at least as new as the argument.
src/Data/Reactive.hs view
@@ -434,7 +434,7 @@     { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) } instance Pair f => Pair (Reactive :. f) where pair = apPair -instance Unpair Reactive where {pfst = fmap fst; psnd = fmap snd}+instance Unpair Reactive where {fsts = fmap fst; snds = fmap snd}  -- Standard instances instance Monoid_f Event where@@ -447,7 +447,7 @@   pair = copair  -- Standard instance for functors-instance Unpair Event where {pfst = fmap fst; psnd = fmap snd}+instance Unpair Event where {fsts = fmap fst; snds = fmap snd}
− src/Data/SEvent.hs 
@@ -1,168 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving-  , FlexibleInstances, FlexibleContexts, TypeSynonymInstances-  , MultiParamTypeClasses-  #-}--------------------------------------------------------------------------- |--- Module      :  Data.SEvent--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Denotational semantics for events-------------------------------------------------------------------------module Data.SEvent-  (-    -- * Event primitives-    Event'(..), accumE-  ) where--import Data.Monoid-import Control.Applicative-import Control.Monad---- TypeCompose-import Control.Compose (Binop,DistribM(..))--import Data.SFuture---{-----------------------------------------------------------    Event primitives-----------------------------------------------------------}---- | Generalized 'Event' over arbitrary (ordered) time type.  See also--- 'Event\''. -newtype Event' t a = E { unE :: [Future t a] }---- | Apply a unary function within the 'Ascend' constructor.-inE :: ([Future t a] -> [Future t b]) -> (Event' t a -> Event' t b)-inE f = E . f . unE---- | Apply a binary function within the 'E' constructor.-inE2 :: ([Future t a] -> [Future t b] -> [Future t c])-     -> (Event' t a -> Event' t b -> Event' t c)-inE2 f = inE . f . unE----- Note: the semantics of Applicative and Monad are not consistent with--- ---   type Event = [] :. Fut--- --- because that composition would combine future values with []-style--- backtracking instead of temporal interleaving.--- --- However, maybe there's a []-wrapping newtype I can use instead.--instance Ord t => Monoid (Event' t a) where-  mempty  = E []-  mappend = inE2 merge--instance Functor (Event' t) where-  fmap f = inE ((fmap.fmap) f)--instance Ord t => Applicative (Event' t) where-  pure  = return-  (<*>) = ap--instance Ord t => Monad (Event' t) where-  return a = E ((return.return) a)-  e >>= f  = joinE (f <$> e)---- This MonadPlus instance could go in EventExtras, but it would be an--- orphan there.-instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }---- For monad compositions.--- We'll need this instance in MEvent.  It'd be an orphan there.-instance Ord t => DistribM (Event' t) Maybe where-  -- distribM :: Maybe (Event' t b) -> Event' t (Maybe b)-  distribM = maybe mempty (fmap Just)---- | Equivalent to 'join' for 'Event'.  More efficient?-joinE :: Ord t => Event' t (Event' t a) -> Event' t a-joinE = inE $ concatF . (fmap.fmap) unE---- Derivation:--- ---       Event (Event a) ---   --> [Fut (Event a)]  -- unE---   --> [Fut [Fut a]]    -- (fmap.fmap) unE---   --> [Fut a]          -- concatF---   --> Event a          -- E---- My previous attempt:---- joinE :: Ord t => Event' t (Event' t a) -> Event' t a--- joinE = mconcat . fmap (E . fmap join . sequenceF . fmap unE) . unE------ Derivation:--- ---       Event (Event a) ---   --> [Fut (Event a)]  -- unE---   --> [Fut [Fut a]]    -- (fmap.fmap) unE---   --> [[Fut (Fut a)]]  -- fmap sequenceF---   --> [[Fut a]]        -- (fmap.fmap) join---   --> [Event a]        -- fmap E---   --> Event a          -- mconcat---- I don't think joinE works as I want.  The join on Fut makes sure that--- the inner occurrences follow the outer, but I don't think fact is--- visible to the implementation.  Also, note that the mconcat could have--- an infinite number of lists to merge.--flatFFs :: Ord t => Future t [Future t a] -> [Future t a]-flatFFs = fmap join . sequenceF--concatF :: Ord t => [Future t [Future t a]] -> [Future t a]-concatF = futVal . foldr mergeF (pure [])---- Binary merge.  The second argument is required to have the property--- that sub-futures are all at least as late as the containing future.--- The result is then guaranteed to have the same property, which allows--- use of futVal instead of flatFFs in concatF.-mergeF :: Ord t => Binop (Future t [Future t a])-ffa `mergeF` Future (tb,futbs) =-  -- First the a values before tb, then interleave the rest of the a-  -- values with the b values.  -  Future (futTime ffa, prefa ++ (suffa `merge` futbs))- where-   (prefa,suffa) = span ((<= tb).futTime) (flatFFs ffa)---- TODO: try out a more efficient version of mergeF that doesn't use--- (++).  Idea: add a span to Data.DList and use it.  Efficient &--- elegant.----- | Accumulating event, starting from an initial value and a--- update-function event.  See also 'accumR'.-accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a-accumE a = inE $ \ futfs -> accum (pure a) (fmap (<*>) futfs)---{---------------------------------------------------------------------    Misc utilities---------------------------------------------------------------------}---- | Merge two ordered lists into an ordered list.-merge :: Ord a => [a] -> [a] -> [a]-[]         `merge` vs         = vs-us         `merge` []         = us-us@(u:us') `merge` vs@(v:vs') =-  if u <= v then-    u : (us' `merge` vs )-  else-    v : (us  `merge` vs')---accum :: a -> [a->a] -> [a]-accum _ [] = []-accum a (f:fs) = a' : accum a' fs where a' = f a---- or---   accum a = tail . scanl (flip ($)) a
− src/Data/SImproving.hs 
@@ -1,60 +0,0 @@-{-# OPTIONS -Wall #-}-------------------------------------------------------------------------- |--- Module      :  Data.Improving--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy--- in an Abstract Data Type with Deterministic Semantics\".--- --- TODO: an efficient, referentially transparent, side-effecting version.-------------------------------------------------------------------------module Data.Improving-  (-    Improving(..), exact-  -- , Improves, merge-  -- , Future(..)-  ) where--import Data.Function (on)---- | Progressive information about a value (e.g., a time)-data Improving t = AtLeast t (Improving t) | Exactly t deriving Show---- | Extract an exact value from an improving value-exact :: Improving t -> t-exact (AtLeast _ u) = exact u-exact (Exactly t)   = t--instance Eq t => Eq (Improving t) where-  (==) = (==) `on` exact--instance Ord t => Ord (Improving t) where-  Exactly s `compare` Exactly t = s `compare` t-  AtLeast s u' `compare` v@(Exactly t) =-    if s > t then GT else u' `compare` v-  u@(Exactly s) `compare` AtLeast t v' =-    if s < t then LT else u  `compare` v'-  u@(AtLeast s u') `compare` v@(AtLeast t v') =-    -- move forward where we know less-    if s <= t then-      u' `compare` v-    else-      u  `compare` v'--  Exactly s `min` Exactly t = Exactly (s `min` t)-  AtLeast s u' `min` v@(Exactly t) =-    if s > t then v else u' `min` v-  u@(Exactly s) `min` AtLeast t v' =-    if s < t then u else u  `min` v'-  u@(AtLeast s u') `min` v@(AtLeast t v') =-    -- move forward where we know less-    if s <= t then-      u' `min` v-    else-      u  `min` v'
− src/Data/SReactive.hs 
@@ -1,169 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}-------------------------------------------------------------------------- |--- Module      :  Data.SReactive--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Simple, semantics-based reactive values-------------------------------------------------------------------------module Data.SReactive-  (-    -- * Primitives-    Reactive'(..), stepper-  , joinR-    -- * Extras (defined via primitives)-  , Reactive-  , switcher, snapshot, snapshot_, whenE-  , accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR-  ) where--import Control.Applicative-import Control.Monad-import Data.Monoid---- TypeCompose-import Control.Compose (Unop)-import Data.Pair (Pair(..),pairEdit)--import Data.EventExtras-import Data.Improving---{-----------------------------------------------------------    Primitives-----------------------------------------------------------}--data Reactive' t a =-  Stepper {-    rInit  :: a                         -- ^ initial value-  , rEvent :: Event' t a                -- ^ waiting for event-  }---- | Reactive value from an initial value and a new-value event.-stepper :: a -> Event' t a -> Reactive' t a-stepper = Stepper---instance Ord t => Pair (Reactive' t) where-  -- pair :: Reactive' t a -> Reactive' t b -> Reactive' t (a,b)-  (c `Stepper` ce) `pair` (d `Stepper` de) =-    (c,d) `accumR` pairEdit (ce,de)--instance Functor (Reactive' t) where-  fmap f (a `Stepper` e) = f a `stepper` fmap f e--instance Ord t => Applicative (Reactive' t) where-  pure a = a `stepper` mempty-  -- Standard definition.  See 'Pair'.-  rf <*> rx = uncurry ($) <$> (rf `pair` rx)---- A wonderful thing about the <*> definition for Reactive' t is that it--- automatically caches the previous value of the function or argument--- when the argument or function changes.--instance Ord t => Monad (Reactive' t) where-  return  = pure-  r >>= f = joinR (f <$> r)---- | Reactive' t 'join' (equivalent to 'join' but slightly more efficient, I think)-joinR :: Ord t => Reactive' t (Reactive' t a) -> Reactive' t a-joinR ((a `Stepper` e) `Stepper` er) = -  a `stepper` (e `mappend` join (rToE <$> er))---- | Turn a reactive value into an event, given a time for the initial--- occurrence.-rToE :: Ord t => Reactive' t a -> Event' t a-rToE (a `Stepper` e) = pure a `mappend` e---- e  :: Event' t a--- er :: Event' t (Reactive' t a)--- --- rToE <$> er ::: Event' t (Event' t a)--- join (rToE <$> er) ::: Event' t a---- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@--- didn't.-snap :: forall a b t. Ord t =>-        Event' t a -> Reactive' t b -> Event' t (Maybe a, b)-ea `snap` (b0 `Stepper` eb) =-  (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)- where-   fa :: a -> Unop (Maybe a, b)-   fb :: b -> Unop (Maybe a, b)-   fa a (_,b) = (Just a , b)-   fb b _     = (Nothing, b)---{-----------------------------------------------------------    Extras (defined via primitives)-----------------------------------------------------------}--type Reactive = Reactive' (Improving Double)---- | Snapshot a reactive value whenever an event occurs.-snapshot :: Ord t => Event' t a -> Reactive' t b -> Event' t (a,b)-e `snapshot` r = joinMaybes $ fmap f (e `snap` r)- where-   f (Nothing,_) = Nothing-   f (Just a ,b) = Just (a,b)---- | Switch between reactive values.-switcher :: Ord t => Reactive' t a -> Event' t (Reactive' t a) -> Reactive' t a-r `switcher` e = joinR (r `stepper` e)---- | Like 'snapshot' but discarding event data (often @a@ is @()@).-snapshot_ :: Ord t => Event' t a -> Reactive' t b -> Event' t b-e `snapshot_` src = snd <$> (e `snapshot` src)---- | Filter an event according to whether a boolean source is true.-whenE :: Ord t => Event' t a -> Reactive' t Bool -> Event' t a-whenE e = joinMaybes . fmap h . snapshot e- where-   h (a,True)  = Just a-   h (_,False) = Nothing----- | Reactive' t value from an initial value and an updater event.  See also--- 'accumE'.-accumR :: Ord t => a -> Event' t (a -> a) -> Reactive' t a-a `accumR` e = a `stepper` (a `accumE` e)---- | Like 'scanl' for reactive values.  See also 'scanlE'.-scanlR :: Ord t => (a -> b -> a) -> a -> Event' t b -> Reactive' t a-scanlR f a e = a `stepper` scanlE f a e---- | Accumulate values from a monoid-valued event.  Specialization of--- 'scanlE', using 'mappend' and 'mempty'.  See also 'monoidE'.-monoidR :: (Ord t, Monoid a) => Event' t a -> Reactive' t a-monoidR = scanlR mappend mempty---- | Start out blank ('Nothing'), latching onto each new @a@, and blanking--- on each @b@.  If you just want to latch and not blank, then use--- 'mempty' for @lose@.-maybeR :: Ord t => Event' t a -> Event' t b -> Reactive' t (Maybe a)-maybeR get lose =-  Nothing `stepper` (fmap Just get `mappend` (Nothing <$ lose))---- | Flip-flopping source.  Turns true when @ea@ occurs and false when--- @eb@ occurs.-flipFlop :: Ord t => Event' t a -> Event' t b -> Reactive' t Bool-flipFlop ea eb =-  False `stepper` ((True <$ ea) `mappend` (False <$ eb))---- TODO: generalize 'maybeR' & 'flipFlop'.  Perhaps using 'Monoid'.--- Note that Nothing and (Any False) are mempty.---- | Count occurrences of an event.  See also 'countE'.-countR :: (Ord t, Num n) => Event' t a -> Reactive' t n-countR e = 0 `stepper` countE_ e---- | Tracing of reactive values-traceR :: (a -> String) -> Unop (Reactive' t a)-traceR shw (a `Stepper` e) = a `Stepper` traceE shw e-
− src/Data/Unamb.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE RecursiveDo #-}-------------------------------------------------------------------------- |--- Module      :  Data.Unamb--- Copyright   :  (c) Conal Elliott 2008--- License     :  BSD3--- --- Maintainer  :  conal@conal.net--- Stability   :  experimental--- --- Unambiguous choice-------------------------------------------------------------------------module Data.Unamb-  (-    unamb, amb, race, assuming-  ) where---- For hang-import Control.Monad (forever)-import System.IO.Unsafe---- For unamb-import Control.Concurrent-import Control.Exception (evaluate)----- | Unambiguous choice operator.  Equivalent to the ambiguous choice--- operator, but with arguments restricted to be equal where not bottom,--- so that the choice doesn't matter.  See also 'amb'.-unamb :: a -> a -> a-a `unamb` b = unsafePerformIO (a `amb` b)----- | Ambiguous choice operator.  Yield either value.  Evaluates in--- separate threads and picks whichever finishes first.  See also--- 'unamb' and 'race'.-amb :: a -> a -> IO a-a `amb` b = evaluate a `race` evaluate b---- | Race two actions against each other in separate threads, and pick--- whichever finishes first.  See also 'amb'.-race :: IO a -> IO a -> IO a-a `race` b = -  -- Evaluate a and b in concurrent threads.  Whichever thread finishes-  -- first kill the other thread.-  do v    <- newEmptyMVar  -- to hold a or b-     lock <- newEmptyMVar  -- to avoid double-kill-     -- Evaluate one value and kill the other.-     let run io tid = forkIO $ do x <- io-                                  putMVar lock ()-                                  killThread tid-                                  putMVar v x-     mdo ta <- run a tb-         tb <- run b ta-         return ()-     readMVar v---- Without using unsafePerformIO, is there a way to define a--- non-terminating but non-erroring pure value that consume very little--- resources while not terminating?---- | Never yield an answer.  Like 'undefined' or 'error "whatever"', but--- don't raise an error, and don't consume computational resources.-hang :: a-hang = unsafePerformIO hangIO---- | Block forever-hangIO :: IO a-hangIO = do -- putStrLn "warning: blocking forever."-            -- Any never-terminating computation goes here-            -- This one can yield an exception "thread blocked indefinitely"-            -- newEmptyMVar >>= takeMVar-            -- sjanssen suggests this alternative:-            forever $ threadDelay maxBound-            -- forever's return type is (), though it could be fully-            -- polymorphic.  Until it's fixed, I need the following line.-            return undefined----- | Yield a value if a condition is true.  Otherwise wait forever.-assuming :: Bool -> a -> a-assuming c a = if c then a else hang
− src/Examples.hs 
@@ -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 Data.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)-