reactive 0.0 → 0.2
raw patch · 5 files changed
+155/−99 lines, 5 files
Files
- reactive.cabal +2/−5
- src/Data/Future.hs +53/−47
- src/Data/Reactive.hs +26/−12
- src/Data/SFuture.hs +11/−23
- src/Examples.hs +63/−12
reactive.cabal view
@@ -1,5 +1,5 @@ Name: reactive-Version: 0.0+Version: 0.2 Synopsis: Simple foundation for functional reactive programming Category: reactivity, FRP Description:@@ -10,9 +10,6 @@ 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@@ -23,7 +20,7 @@ Maintainer: conal@conal.net Homepage: http://haskell.org/haskellwiki/reactive Package-Url: http://darcs.haskell.org/packages/reactive-Copyright: (c) 2007 by Conal Elliott+Copyright: (c) 2007-2008 by Conal Elliott License: BSD3 Stability: provisional Hs-Source-Dirs: src
src/Data/Future.hs view
@@ -47,16 +47,15 @@ ---------------------------------------------------------------------- module Data.Future- ( Future, force, newFuture+ ( Future(..), force, newFuture , future- , never, race, race' , runFuture ) where import Control.Concurrent import Data.Monoid (Monoid(..)) import Control.Applicative-import Control.Monad (join)+import Control.Monad (join,forever) import System.IO.Unsafe -- import Foreign (unsafePerformIO) @@ -81,36 +80,57 @@ -- 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.- }+data Future a =+ -- | Future that may arrive. The 'IO' blocks until available. No side-effect.+ Future (IO a)+ -- | Future that never arrives.+ | Never +-- Why not simply use @a@ (plain-old lazy value) in place of @IO a@ in+-- 'Future'? Several of the definitions below get simpler, and many+-- examples work. See NewFuture.hs. But sometimes that implementation+-- mysteriously crashes or just doesn't update. Odd.++-- | Access a future value. Blocks until available.+force :: Future a -> IO a+force (Future io) = io+force Never = hang++-- | Block forever+hang :: IO a+hang = do -- putStrLn "warning: blocking forever."+ -- Any never-terminating computation goes here+ -- This one can yield an exception "thread blocked indefinitely"+ -- newEmptyMVar >>= takeMVar+ -- sjanssen suggests this alternative:+ forever $ threadDelay maxBound+ -- forever's return type is (), though it could be fully+ -- polymorphic. Until it's fixed, I need the following line.+ return undefined+ -- | Make a 'Future' and a way to fill it. The filler should be invoked--- only once. Later fillings may block.+-- only once. newFuture :: IO (Future a, a -> IO ()) newFuture = do v <- newEmptyMVar return (Future (readMVar v), putMVar v) --- | Make a 'Future', given a way to compute a (lazy) value.+-- | Make a 'Future', given a way to compute a 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+ do (fut,sink) <- newFuture+ forkIO $ mka >>= sink return fut {-# NOINLINE future #-} instance Functor Future where fmap f (Future get) = future (fmap f get)+ fmap _ Never = Never instance Applicative Future where pure a = Future (pure a) Future getf <*> Future getx = future (getf <*> getx)+ _ <*> _ = Never -- Note Applicative's pure uses 'Future' as an optimization over -- 'future'. No thread or MVar.@@ -118,44 +138,30 @@ instance Monad Future where return = pure Future geta >>= h = future (geta >>= force . h)+ Never >>= _ = Never instance Monoid (Future a) where- mempty = never- mappend = race'---- | A future that will never happen-never :: Future a-never = fst (unsafePerformIO newFuture)-{-# NOINLINE never #-}+ mempty = Never+ mappend = race --- | A future equal to the earlier available of two given futures. See also 'race\''.+-- | Race to extract a value. 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+Never `race` b = b+a `race` Never = a+a `race` b = unsafePerformIO $+ do (c,sink) <- newFuture+ let run fut tid = forkIO $ do x <- force fut+ killThread tid+ sink x+ mdo ta <- run a tb+ tb <- run b ta+ return ()+ return c {-# 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.+-- TODO: make race deterministic, using explicit times. Figure out how+-- one thread can inquire whether the other whether it is available by a+-- given time, and if so, what time. -- | Run an 'IO'-action-valued 'Future'. runFuture :: Future (IO ()) -> IO ()
src/Data/Reactive.hs view
@@ -41,7 +41,7 @@ , withPrevE, countE, countE_, diffE , snapshot, snapshot_, whenE, once, traceE, eventX -- * Reactive extras- , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR+ , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR -- * Reactive behaviors , Time, ReactiveB -- * To be moved elsewhere@@ -154,14 +154,17 @@ mempty = Event mempty mappend = inEvent2 merge --- Standard instance for Applicative of Monid+-- Standard instance for Applicative of Monoid instance Monoid a => Monoid (Reactive a) where mempty = pure mempty mappend = liftA2 mappend -- | Merge two 'Future' streams into one. merge :: Future (Reactive a) -> Future (Reactive a) -> Future (Reactive a)-u `merge` v = (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v)+Never `merge` fut = fut+fut `merge` Never = fut+u `merge` v =+ (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v) where onFut f (a `Stepper` Event t') = a `stepper` Event (f t') @@ -191,28 +194,35 @@ instance Monad Event where return a = Event (pure (pure a))- e >>= f = joinE (fmap f e)--instance MonadPlus Event where { mzero = mempty; mplus = mappend }+ e >>= f = joinE (fmap f e) joinE :: forall a. Event (Event a) -> Event a joinE = inEvent q where q :: Future (Reactive (Event a)) -> Future (Reactive a)- q futre = futre >>= eFuture . h+ q = (>>= eFuture . h) h :: Reactive (Event a) -> Event a h (ea `Stepper` eea) = ea `mappend` joinE eea +instance MonadPlus Event where { mzero = mempty; mplus = mappend }+ instance Monad Reactive where- return = pure- a `Stepper` ea >>= h = h a `switcher` (h <$> ea)+ return = pure+ r >>= h = joinR (fmap h r) -- | Switch between reactive values. switcher :: Reactive a -> Event (Reactive a) -> Reactive a-r `switcher` e = join (r `stepper` e)+r `switcher` e = joinR (r `stepper` e) --- TODO: is the mutual recursion of (>>=) --> switcher --> join --> (>>=)--- well-founded?+-- Reactive 'join'+joinR :: Reactive (Reactive a) -> Reactive a+joinR ((a `Stepper` Event fut) `Stepper` e'@(Event fut')) =+ a `stepper` Event fut''+ where+ -- If fut arrives first, switch and continue waiting for e'.+ -- If fut' arrives first, abandon fut and keep switching with new+ -- reactive values from fut'.+ fut'' = fmap (`switcher` e') fut `mappend` fmap join fut' -- | Make an event and a sink for feeding the event. Each value sent to -- the sink becomes an occurrence of the event.@@ -390,6 +400,10 @@ -- | Count occurrences of an event countR :: Num n => Event a -> Reactive n countR e = 0 `stepper` countE_ e++-- | Tracing of reactive values+traceR :: (a -> String) -> Unop (Reactive a)+traceR shw (a `Stepper` e) = a `Stepper` traceE shw e {--------------------------------------------------------------------
src/Data/SFuture.hs view
@@ -53,7 +53,7 @@ import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..))-import Data.Function (on)+-- 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@@ -76,17 +76,11 @@ 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 (<=)-+-- The Monoid instance picks the earlier future instance Ord t => Monoid (Future t a) where mempty = Future (maxBound, error "it'll never happen, buddy")- mappend = min+ fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) =+ if t <= t' then fut else fut' -------- To go elsewhere@@ -98,7 +92,7 @@ deriving (Eq, Ord, Read, Show, Bounded) instance (Ord a, Bounded a) => Monoid (Max a) where- mempty = Max maxBound+ mempty = Max minBound Max a `mappend` Max b = Max (a `max` b) -- | Ordered monoid under 'min'.@@ -106,7 +100,7 @@ deriving (Eq, Ord, Read, Show, Bounded) instance (Ord a, Bounded a) => Monoid (Min a) where- mempty = Min minBound+ mempty = Min maxBound Min a `mappend` Min b = Min (a `min` b) -- I have a niggling uncertainty about the 'Ord' & 'Bounded' instances for@@ -118,8 +112,8 @@ -- Equivalent to the Monad Writer instance. -- import Data.Monoid instance Monoid o => Monad ((,) o) where- return = pure- (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a+ return = pure+ (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a -- Alternatively, -- m >>= f = join (fmap f m)@@ -139,14 +133,8 @@ -- | 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)+ deriving (Eq, Ord, Read, Show) instance Bounded (AddBounds a) where- minBound = MinBound- maxBound = MaxBound----------- Example ---- t1 :: Future Int Double--- t1 = pure sin <*> pure pi+ minBound = MinBound+ maxBound = MaxBound
src/Examples.hs view
@@ -16,10 +16,11 @@ -- base import Data.Monoid+import Data.IORef import Control.Monad ((>=>),forM_) import Control.Applicative import Control.Arrow (first,second)-import Control.Concurrent (forkIO, killThread, threadDelay, ThreadId)+import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId) -- wxHaskell import Graphics.UI.WX hiding (Event,Reactive)@@ -85,16 +86,42 @@ s <- hslider win True lo hi [ selection := initial ] set s [ on command := getAttr selection s >>= snk ]- return (hwidget s, {-traceE shw-} e)+ return (hwidget s, 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)+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 @@ -132,8 +159,11 @@ (l,o) <- unWio w pan set pan [ layout := l ] forker o- set f [ layout := fill (widget pan)- , visible := True+ -- 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'@@ -179,15 +209,36 @@ 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" $ sliderR (0,10) 3-bananas = title "bananas" $ sliderR (0,10) 7+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 (sliderR (0,10) 0)+t4 = forkWioR "t4" $ liftA2 (<*>) showR (sl 0) -t5 = forkWioR "t5" $ liftA2 (<$>) showO (sliderR (0,10) 0)+t5 = forkWioR "t5" $ liftA2 (<$>) showO (sl 0) -main = t3+-- 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