diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,3 @@ +# For special configuration, especially for docs. Otherwise see README. + +include ../my-cabal-make.inc diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/reactive.cabal b/reactive.cabal new file mode 100644 --- /dev/null +++ b/reactive.cabal @@ -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: + . + The module documentation pages have links to colorized source code and + to wiki pages where you can read and contribute user comments. Enjoy! + . + © 2007 by Conal Elliott; BSD3 license. +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 diff --git a/src/Data/Fun.hs b/src/Data/Fun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fun.hs @@ -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 diff --git a/src/Data/Future.hs b/src/Data/Future.hs new file mode 100644 --- /dev/null +++ b/src/Data/Future.hs @@ -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 . +-- +-- 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 + diff --git a/src/Data/Reactive.hs b/src/Data/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Reactive.hs @@ -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 diff --git a/src/Data/SFuture.hs b/src/Data/SFuture.hs new file mode 100644 --- /dev/null +++ b/src/Data/SFuture.hs @@ -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 . +-- +-- 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 diff --git a/src/Examples.hs b/src/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Examples.hs @@ -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