reactive (empty) → 0.0

raw patch · 9 files changed

+1101/−0 lines, 9 filesdep +TypeComposedep +basebuild-type:Customsetup-changed

Dependencies added: TypeCompose, base

Files

Makefile +3/−0
README +31/−0
Setup.lhs +3/−0
reactive.cabal +38/−0
src/Data/Fun.hs +52/−0
src/Data/Future.hs +163/−0
src/Data/Reactive.hs +466/−0
src/Data/SFuture.hs +152/−0
src/Examples.hs +193/−0

+ Makefile view

@@ -0,0 +1,3 @@+# For special configuration, especially for docs.  Otherwise see README.++include ../my-cabal-make.inc

+ README view

@@ -0,0 +1,31 @@+_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

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ reactive.cabal view

@@ -0,0 +1,38 @@+Name:                reactive+Version:             0.0+Synopsis: 	     Simple foundation for functional reactive programming+Category:            reactivity, FRP+Description:+  /Reactive/ is a simple foundation for programming reactive systems+  functionally.  Like Fran\/FRP, it has a notions of (reactive) behaviors and+  events.  Like DataDriven, Reactive has a data-driven implementation.+  The main difference between Reactive and DataDriven is that Reactive+  builds on functional \"futures\" (using threading), while DataDriven+  builds on continuation-based computations.+  .+  Warning: executables using this library must be built with+  @-threaded@.  Otherwise, reactions will be delayed significantly.+  .+  Please see the project wiki page: <http://haskell.org/haskellwiki/reactive>+  .+  The module documentation pages have links to colorized source code and+  to wiki pages where you can read and contribute user comments.  Enjoy!+  .+  &#169; 2007 by Conal Elliott; BSD3 license.+Author:              Conal Elliott +Maintainer:          conal@conal.net+Homepage:            http://haskell.org/haskellwiki/reactive+Package-Url:	     http://darcs.haskell.org/packages/reactive+Copyright:           (c) 2007 by Conal Elliott+License:             BSD3+Stability:           provisional+Hs-Source-Dirs:      src+Extensions:          +Build-Depends:       base, TypeCompose+Exposed-Modules:     +		     Data.SFuture+		     Data.Future+		     Data.Fun+		     Data.Reactive+Extra-Source-Files:+ghc-options:         -Wall -O

+ src/Data/Fun.hs view

@@ -0,0 +1,52 @@+----------------------------------------------------------------------+-- |+-- 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 Control.Applicative (Applicative(..))+import Control.Arrow hiding (pure)++-- | 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 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 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')+  f     *** g     = first f >>> second g

+ src/Data/Future.hs view

@@ -0,0 +1,163 @@+{-# LANGUAGE RecursiveDo #-}+{-# OPTIONS -fno-warn-orphans #-}++----------------------------------------------------------------------+-- |+-- 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+  , never, race, race'+  , runFuture+  ) where++import Control.Concurrent+import Data.Monoid (Monoid(..))+import Control.Applicative+import Control.Monad (join)+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.+newtype Future a =+  Future {+    force :: IO a -- ^ Get a future value.  Blocks until the value is+                  -- available.  No side-effect.+  }++-- | Make a 'Future' and a way to fill it.  The filler should be invoked+-- only once.  Later fillings may block.+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 (lazy) value.+future :: IO a -> Future a+future mka = unsafePerformIO $+             do (fut,snk) <- newFuture+                -- let snk' a = putStrLn "sink" >> snk a+                -- putStrLn "fork"+                forkIO $ mka >>= snk+                return fut+{-# NOINLINE future #-}++instance Functor Future where+  fmap f (Future get) = future (fmap f get)++instance Applicative Future where+  pure a                      = Future (pure a)+  Future getf <*> Future getx = future (getf <*> getx)++-- 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)++instance Monoid (Future a) where+  mempty  = never+  mappend = race'++-- | A future that will never happen+never :: Future a+never = fst (unsafePerformIO newFuture)+{-# NOINLINE never #-}++-- | A future equal to the earlier available of two given futures.  See also 'race\''.+race :: Future a -> Future a -> Future a+Future geta `race` Future getb =+  unsafePerformIO $+  do (w,snk) <- newFuture+     let run get = forkIO $ get >>= snk+     run geta+     run getb+     return w+{-# NOINLINE race #-}++-- | Like 'race', but the winner kills the loser's thread.+race' :: Future a -> Future a -> Future a+Future geta `race'` Future getb =+  unsafePerformIO $+  do (w,snk) <- newFuture+     let run get tid = forkIO $ do a <- get+                                   killThread tid+                                   snk a+     mdo ta <- run geta tb+         tb <- run getb ta+         return ()+     return w+{-# NOINLINE race' #-}++-- TODO: make race & race' deterministic, using explicit times.  Figure+-- out how one thread can inquire whether the other whether it is+-- available by a given time, and if so, what time.++-- | Run an 'IO'-action-valued 'Future'.+runFuture :: Future (IO ()) -> IO ()+runFuture = join . force+

+ src/Data/Reactive.hs view

@@ -0,0 +1,466 @@+{-# LANGUAGE TypeOperators, ScopedTypeVariables, PatternSignatures+           , FlexibleInstances+ #-}++----------------------------------------------------------------------+-- |+-- 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+    -- * 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)++-- 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/.+-- +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 Monid+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)+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 vf) <*> rx@(x `Stepper` Event vx) =+   f x `stepper` Event (((<*> rx) <$> vf) `mappend` ((rf <*>) <$> vx))++-- 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)++instance MonadPlus Event where { mzero = mempty; mplus = mappend }++joinE :: forall a. Event (Event a) -> Event a+joinE = inEvent q+ where+   q :: Future (Reactive (Event a)) -> Future (Reactive a)+   q futre = futre >>= eFuture . h+   h :: Reactive (Event a) -> Event a+   h (ea `Stepper` eea) = ea `mappend` joinE eea++instance Monad Reactive where+  return = pure+  a `Stepper` ea >>= h = h a `switcher` (h <$> ea)++-- | Switch between reactive values.+switcher :: Reactive a -> Event (Reactive a) -> Reactive a+r `switcher` e = join (r `stepper` e)++-- TODO: is the mutual recursion of (>>=) --> switcher --> join --> (>>=)+-- well-founded?++-- | 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.+accumE :: a -> Event (a -> a) -> Event a+accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'++-- | Like 'scanl' for events+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'+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'.+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.+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+accumR :: a -> Event (a -> a) -> Reactive a+a `accumR` e = a `stepper` (a `accumE` e)++-- | Like 'scanl' for reactive values+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'+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+countR :: Num n => Event a -> Reactive n+countR e = 0 `stepper` countE_ 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 {pfst = fmap fst; psnd = 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 {pfst = fmap fst; psnd = fmap snd}++++{--------------------------------------------------------------------+    Reactive behaviors over continuous time+--------------------------------------------------------------------}++-- | Time for continuous behaviors+type Time = Double++-- | Reactive behaviors.  Simply a reactive 'Fun'ction value.  Wrapped in+-- a type composition to get 'Functor' and 'Applicative' for free.+type ReactiveB = Reactive :. Fun Time+++{--------------------------------------------------------------------+    To be moved elsewhere+--------------------------------------------------------------------}++-- | Replace a functor value with a given one.+replace :: Functor f => b -> f a -> f b+replace b = fmap (const b)++-- | Forget a functor value, replace with @()@+forget :: Functor f => f a -> f ()+forget = replace ()++-- | Convenient alias for dropping parentheses.+type Action = IO ()++-- | Value sink+type Sink a = a -> Action++-- | Pass through @Just@ occurrences.+joinMaybes :: MonadPlus m => m (Maybe a) -> m a+joinMaybes = (>>= maybe mzero return)++-- | Pass through values satisfying @p@.+filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a+filterMP p m = joinMaybes (liftM f m)+ where+   f a | p a       = Just a+       | otherwise = Nothing++-- Alternatively:+-- filterMP p m = m >>= guarded p+--  where+--    guarded p x = guard (p x) >> return x

+ src/Data/SFuture.hs view

@@ -0,0 +1,152 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- 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.+----------------------------------------------------------------------++module Data.SFuture where++import Data.Monoid (Monoid(..))+import Control.Applicative (Applicative(..))+import Data.Function (on)++-- | 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 (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++instance Eq (Future t a) where+  (==) = error "sorry, no (==) for futures"++instance Ord t => Ord (Future t a) where+  (<=) = (<=) `on` (fst.force)++-- The other Ord methods, including min & max, follow from (<=)++instance Ord t => Monoid (Future t a) where+  mempty  = Future (maxBound, error "it'll never happen, buddy")+  mappend = min+++-------- 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 maxBound+	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 minBound+	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+++-------- Example ++-- t1 :: Future Int Double+-- t1 = pure sin <*> pure pi

+ src/Examples.hs view

@@ -0,0 +1,193 @@+{-# 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 Control.Monad ((>=>),forM_)+import Control.Applicative+import Control.Arrow (first,second)+import Control.Concurrent (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, {-traceE shw-} e)++sliderR :: (Int,Int) -> Int -> WioR Int+sliderR lh initial = stepper initial <$> sliderE lh initial++stringO :: Wio (Sink String)+stringO = wio $ \ win ->+  do ctl <- textEntry win []+     return (hwidget ctl, setAttr text ctl)++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+      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++apples, bananas, fruit :: WioR Int+apples  = title "apples"  $ sliderR (0,10) 3+bananas = title "bananas" $ sliderR (0,10) 7+fruit   = title "fruit"   $ (liftA2.liftA2) (+) apples bananas++t3 = forkWioR "t3" $ liftA2 (<**>) fruit total ++t4 = forkWioR "t4" $ liftA2 (<*>) showR (sliderR (0,10) 0)++t5 = forkWioR "t5" $ liftA2 (<$>) showO (sliderR (0,10) 0)++main = t3