sodium 0.6.0.1 → 0.6.0.2
raw patch · 15 files changed
+365/−147 lines, 15 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- FRP.Sodium.Internal: runListen :: Listen a -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())
- FRP.Sodium.Internal: unSample_ :: Sample a -> IO (IO a)
- FRP.Sodium.Internal: unlistenize :: Reactive (IO ()) -> Reactive Unlistener
+ FRP.Sodium.Internal: later :: Reactive (IO ()) -> Reactive Unlistener
+ FRP.Sodium.Internal: sDep :: Sample a -> Dep
- FRP.Sodium.Internal: Sample :: IO (IO a) -> Sample a
+ FRP.Sodium.Internal: Sample :: IO a -> Dep -> Sample a
- FRP.Sodium.Internal: newEventLinked :: IO (Event a, a -> Reactive (), MVar Node)
+ FRP.Sodium.Internal: newEventLinked :: Dep -> IO (Event a, a -> Reactive (), MVar Node)
Files
- examples/tests/memory-test-1.hs +2/−1
- examples/tests/memory-test-2.hs +2/−1
- examples/tests/memory-test-3.hs +2/−1
- examples/tests/memory-test-4.hs +2/−1
- examples/tests/memory-test-5.hs +2/−1
- examples/tests/memory-test-6.hs +2/−1
- examples/tests/memory-test-6a.hs +28/−0
- examples/tests/memory-test-7.hs +36/−0
- examples/tests/memory-test-8.hs +61/−0
- examples/tests/memory-test-8a.hs +50/−0
- examples/tests/run-memory-tests.sh +20/−0
- examples/tests/unit-tests.hs +1/−1
- sodium.cabal +11/−5
- src/FRP/Sodium/Internal.hs +1/−3
- src/FRP/Sodium/Plain.hs +145/−132
examples/tests/memory-test-1.hs view
@@ -2,6 +2,7 @@ import FRP.Sodium import Control.Applicative import Control.Exception+import System.Timeout verbose = False @@ -19,6 +20,6 @@ switch oout kill <- sync $ listen (values out) $ \x -> if verbose then print x else (evaluate x >> return ())- mapM_ (sync . pushT) [0..]+ timeout 4000000 $ mapM_ (sync . pushT) [0..] kill
examples/tests/memory-test-2.hs view
@@ -3,6 +3,7 @@ import FRP.Sodium import Control.Applicative import Control.Exception+import System.Timeout data Source = Source { unSource :: Reactive (Behaviour (Int, Int), Event Source) } @@ -30,6 +31,6 @@ out <- sync $ switch oout kill <- sync $ listen (values out) $ \x -> if verbose then print x else (evaluate x >> return ())- mapM_ (sync . pushT) [0..]+ timeout 4000000 $ mapM_ (sync . pushT) [0..] kill
examples/tests/memory-test-3.hs view
@@ -3,6 +3,7 @@ import Control.Applicative import Control.Exception import Control.Monad+import System.Timeout verbose = False @@ -15,7 +16,7 @@ switch oout kill <- sync $ listen (values out) $ \x -> if verbose then print x else (evaluate x >> return ())- forM_ [0..] $ \i -> do+ timeout 4000000 $ forM_ [0..] $ \i -> do sync $ pushC () kill
examples/tests/memory-test-4.hs view
@@ -3,6 +3,7 @@ import Control.Applicative import Control.Exception import Control.Monad+import System.Timeout verbose = False @@ -14,7 +15,7 @@ return $ switchE oout kill <- sync $ listen out $ \x -> if verbose then print (x :: Int) else (evaluate x >> return ())- forM_ [0..] $ \i -> do+ timeout 4000000 $ forM_ [0..] $ \i -> do sync $ pushC () kill
examples/tests/memory-test-5.hs view
@@ -3,6 +3,7 @@ import Control.Applicative import Control.Exception import Control.Monad+import System.Timeout verbose = False @@ -12,7 +13,7 @@ out <- sync $ hold 0 eChange kill <- sync $ listen (values out) $ \x -> if verbose then print (x :: Int) else (evaluate x >> return ())- forM_ [0..] $ \i -> do+ timeout 4000000 $ forM_ [0..] $ \i -> do sync $ pushC i kill
examples/tests/memory-test-6.hs view
@@ -4,6 +4,7 @@ import Control.Applicative import Control.Exception import Control.Monad+import System.Timeout verbose = False @@ -22,6 +23,6 @@ switch eFlam kill <- sync $ listen (values out) $ \x -> if verbose then print x else (evaluate x >> return ())- forever $ sync $ push ()+ timeout 4000000 $ forever $ sync $ push () kill
+ examples/tests/memory-test-6a.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception+import Control.Monad+import System.Timeout++verbose = False++flam :: Event () -> Reactive (Event Bool)+flam e = do+ rec+ let eToggle = snapshotWith (\() selected -> not selected) e selected+ selected <- hold False eToggle+ return eToggle++main = do+ (e, push) <- sync newEvent+ out <- sync $ do+ eInit <- flam e+ eFlam <- hold eInit (execute ((const $ flam e) <$> e))+ return $ switchE eFlam+ kill <- sync $ listen out $ \x ->+ if verbose then print x else (evaluate x >> return ())+ timeout 4000000 $ forever $ sync $ push ()+ kill+
+ examples/tests/memory-test-7.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Data.Maybe+import Control.Applicative+import Control.Exception+import Control.Monad+import Control.DeepSeq+import System.Timeout++verbose = False++flam :: Event () -> Behavior Int -> Reactive (Behavior Int)+flam e time = do+ let eStart = snapshot e time+ -- Only allow eStart through when we're not already running+ hold 0 eStart++main = do+ (e, push) <- sync newEvent+ (eFlip, pushFlip) <- sync newEvent+ (time, pushTime) <- sync $ newBehavior 0+ out <- sync $ do+ eInit <- flam e time+ eFlam <- hold eInit (execute ((const $ flam e time) <$> eFlip))+ switch eFlam+ kill <- sync $ listen (values out) $ \x ->+ if verbose then print x else (evaluate (rnf x) >> return ())+ let loop t = do+ sync $ pushTime t+ sync $ push ()+ when (t `mod` 18 == 0) $ sync $ pushFlip ()+ loop (t+1)+ timeout 4000000 $ loop 0+ kill+
+ examples/tests/memory-test-8.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Data.Maybe+import Control.Applicative+import Control.Exception+import Control.Monad+import Control.DeepSeq+import System.Timeout++verbose = False++flam :: Event () -> Behavior Int -> Reactive (Behavior (Maybe Int))+flam e time = do+ -- Test that this arrangement...+ --+ -- changes time+ -- |+ -- v+ -- eStop <-- SNAPSHOT (timer)+ -- | ^+ -- v |+ -- e --> eStart --> GATE --> HOLD |+ -- ^ | |+ -- | v |+ -- notRunning <-- mRunning --> * ---> OUT+ --+ -- ...get cleaned up when 'flam' is switched out. The issue is the + -- GATE/HOLD cycle at the bottom left. + let eStart = snapshotWith (\() t -> Just t) e time+ rec+ let notRunning = fmap (not . isJust) mRunning+ -- Only allow eStart through when we're not already running+ mRunning <- hold Nothing $ merge (eStart `gate` notRunning) eStop++ -- Stop it when it's been running for 5 ticks.+ let eStop = filterJust $ snapshotWith (\t mRunning ->+ case mRunning of+ Just t0 | (t - t0) >= 5 -> Just Nothing+ _ -> Nothing+ ) (changes time) mRunning+ return mRunning++main = do+ (e, push) <- sync newEvent+ (eFlip, pushFlip) <- sync newEvent+ (time, pushTime) <- sync $ newBehavior 0+ out <- sync $ do+ eInit <- flam e time+ eFlam <- hold eInit (execute ((const $ flam e time) <$> eFlip))+ switch eFlam+ kill <- sync $ listen (values out) $ \x ->+ if verbose then print x else (evaluate (rnf x) >> return ())+ let loop t = do+ sync $ pushTime t+ sync $ push ()+ when (t `mod` 18 == 0) $ sync $ pushFlip ()+ loop (t+1)+ timeout 4000000 $ loop 0+ kill+
+ examples/tests/memory-test-8a.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Data.Maybe+import Control.Applicative+import Control.Exception+import Control.Monad+import Control.DeepSeq+import System.Timeout++-- A truncated version of memory-test-8 that still shows the same problem.++verbose = False++flam :: Event () -> Behavior Int -> Reactive (Behavior (Maybe Int))+flam e time = do+ -- Test that this arrangement...+ --+ -- e --> eStart --> GATE --> HOLD+ -- ^ |+ -- | v+ -- notRunning <-- mRunning --> * ---> OUT+ --+ -- ...get cleaned up when 'flam' is switched out. The issue is the + -- GATE/HOLD cycle at the bottom left. + let eStart = snapshotWith (\() t -> Just t) e time+ rec+ -- Only allow eStart through when we're not already running+ mRunning <- hold Nothing $ eStart `gate` notRunning+ let notRunning = fmap (not . isJust) mRunning+ return mRunning++main = do+ (e, push) <- sync newEvent+ (eFlip, pushFlip) <- sync newEvent+ (time, pushTime) <- sync $ newBehavior 0+ out <- sync $ do+ eInit <- flam e time+ eFlam <- hold eInit (execute ((const $ flam e time) <$> eFlip))+ switch eFlam+ kill <- sync $ listen (values out) $ \x ->+ if verbose then print x else (evaluate (rnf x) >> return ())+ let loop t = do+ sync $ pushTime t+ sync $ push ()+ when (t `mod` 18 == 0) $ sync $ pushFlip ()+ loop (t+1)+ timeout 4000000 $ loop 0+ kill+
+ examples/tests/run-memory-tests.sh view
@@ -0,0 +1,20 @@+#!/bin/bash -e+FILES=memory-test-*.hs+for ff in $FILES ; do+ f=${ff%.hs}+ ghc $ff -prof -auto-all+ rm -f $f.done+done+echo running...+for ff in $FILES ; do+ f=${ff%.hs}+ (./$f +RTS -hy ; hp2ps -c $f.hp ; convert -rotate -90 -flatten $f.ps $f.png ; touch $f.done) &+done+for ff in $FILES ; do+ f=${ff%.hs}+ while [[ ! -f "$f.done" ]] ; do+ sleep 0.1+ done+done+echo done+eog *.png
examples/tests/unit-tests.hs view
@@ -534,5 +534,5 @@ switch1, once1, once2, cycle1{-, mergeWith1, mergeWith2, mergeWith3, coalesce1-} ] -main = {-forever $-} runTestTT tests+main = {-forever $ -} runTestTT tests
sodium.cabal view
@@ -1,5 +1,5 @@ name: sodium-version: 0.6.0.1+version: 0.6.0.2 synopsis: Sodium Reactive Programming (FRP) System description: A general purpose Reactive Programming (FRP) system. This is part of a project to@@ -20,19 +20,20 @@ . See the /examples/ directory for test cases and examples. .- Changes: 0.2.0.0 fix some value recursion deadlocks and improve docs;- 0.3.0.0 add mergeWith, make cross asynchronous;+ Changes: 0.2.0.0 Fix some value recursion deadlocks and improve docs;+ 0.3.0.0 Add mergeWith, make cross asynchronous; 0.4.0.0 API revamp to remove an excess type variable. Parallelism stuff to be rethought; 0.5.0.0 Improved tests cases + add Freecell example, API tweaks; 0.5.0.1 Internal improvements; 0.5.0.2 Fix multiple memory leaks; 0.6 Minor API changes, particular with accum;- 0.6.0.1 ghc-7.8 compatibility.+ 0.6.0.1 ghc-7.8 compatibility;+ 0.6.0.2 Fix memory leak - see memory-test-8 & memory-test-8a. license: BSD3 license-file: LICENSE author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/-copyright: (c) Stephen Blackheath 2012+copyright: (c) Stephen Blackheath 2012-2013 category: FRP build-type: Simple cabal-version: >=1.8@@ -44,6 +45,11 @@ examples/tests/memory-test-4.hs examples/tests/memory-test-5.hs examples/tests/memory-test-6.hs+ examples/tests/memory-test-6a.hs+ examples/tests/memory-test-7.hs+ examples/tests/memory-test-8.hs+ examples/tests/memory-test-8a.hs+ examples/tests/run-memory-tests.sh examples/games/poodle.hs examples/games/freecell.hs examples/games/Engine.hs
src/FRP/Sodium/Internal.hs view
@@ -7,7 +7,6 @@ scheduleLast, Listen(..), getListen,- runListen, linkedListen, Node, newEventLinked,@@ -19,9 +18,8 @@ Unlistener, addCleanup_Listen, Sample(..),- unSample, addCleanup_Sample,- unlistenize+ later ) where import qualified FRP.Sodium.Context as C
src/FRP/Sodium/Plain.hs view
@@ -29,6 +29,7 @@ import GHC.Exts import System.Mem.Weak import System.IO.Unsafe+import Unsafe.Coerce modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b modifyMVar mv f = MV.modifyMVar mv $ \a -> do@@ -51,8 +52,8 @@ -- on the last function parameter of the caller to make -- sure that the IORef is freshly created every time -{-# NOINLINE unsafeNewIORef #-} unsafeNewIORef :: a -> b -> IORef a+{-# NOINLINE unsafeNewIORef #-} unsafeNewIORef v dummy = unsafePerformIO (newIORef v) -- | Phantom type for use with 'R.Context' type class.@@ -84,15 +85,10 @@ type Behaviour a = R.Behavior Plain a -- Must be data not newtype, because we need to attach finalizers to it-data Sample a = Sample { unSample_ :: IO (IO a) }--unSample :: Sample a -> IO a-{-# NOINLINE unSample #-}-unSample sample = do- sample' <- unSample_ sample- touch sample -- Ensure 'sample' stays alive while it's- -- being used.- sample'+data Sample a = Sample {+ unSample :: IO a,+ sDep :: Dep+ } instance R.Context Plain where @@ -102,15 +98,17 @@ -- | Listen for event occurrences on this event, to be handled by the specified -- handler. The returned action is used to unregister the listener. getListenRaw :: Reactive (Listen a),- evCacheRef :: IORef (Maybe (Listen a))+ evCacheRef :: IORef (Maybe (Listen a)),+ eDep :: Dep } data Behavior Plain a = Behavior {- -- | Internal: Extract the underlyingEvent event for this behavior.- underlyingEvent :: Event a,+ changes_ :: Event a, -- ^ An event that gives the updates for the behavior. It doesn't do any equality+ -- comparison as the name might imply. -- | Obtain the current value of a behavior.- behSample :: Sample a+ sampleImpl :: Sample a }+ sync = sync ioReactive = ioReactive newEvent = newEvent@@ -129,6 +127,13 @@ coalesce = coalesce once = once +-- | An event that gives the updates for the behavior. If the behavior was created+-- with 'hold', then 'changes' gives you back the event that was passed to 'hold'.+--+-- (It doesn't do any equality comparison as the name might imply.)+changes :: Behavior a -> Event a+changes = changes_+ -- | Execute the specified 'Reactive' within a new transaction, blocking the caller -- until all resulting processing is complete and all callbacks have been called. -- This operation is thread-safe, so it may be called from any thread.@@ -172,9 +177,9 @@ readIORef outVar -- | Returns an event, and a push action for pushing a value into the event.-newEvent :: Reactive (Event a, a -> Reactive ()) +newEvent :: Reactive (Event a, a -> Reactive ()) newEvent = do- (ev, push, _) <- ioReactive newEventLinked+ (ev, push, _) <- ioReactive $ newEventLinked undefined return (ev, push) -- | Listen for firings of this event. The returned @IO ()@ is an IO action@@ -188,14 +193,15 @@ -- that start the new transaction. If you want to do more processing in -- the same transction, then you can use 'FRP.Sodium.Internal.listenTrans' -- but this is discouraged unless you really need to write a new primitive.-listen :: Event a -> (a -> IO ()) -> Reactive (IO ())-listen ev handle = listenTrans ev (ioReactive . handle)+listen :: Event a -> (a -> IO ()) -> Reactive (IO ())+listen ev handle = listenTrans ev $ \a -> ioReactive (handle a >> touch ev) -- | An event that never fires.-never :: Event a+never :: Event a never = Event { getListenRaw = return $ Listen $ \_ _ _ -> return (return ()), - evCacheRef = unsafeNewIORef Nothing undefined+ evCacheRef = unsafeNewIORef Nothing undefined,+ eDep = undefined } -- | Merge two streams of events of the same type.@@ -205,134 +211,136 @@ -- transaction. If the event firings are ordered for some reason, then -- their ordering is retained. In many common cases the ordering will -- be undefined.-merge :: Event a -> Event a -> Event a-merge ea eb = Event gl cacheRef+merge :: Event a -> Event a -> Event a+merge ea eb = Event gl cacheRef (dep (ea, eb)) where cacheRef = unsafeNewIORef Nothing eb gl = do- l1 <- getListen ea- l2 <- getListen eb (l, push, nodeRef) <- ioReactive newEventImpl- unlistener <- unlistenize $ do- u1 <- runListen l1 (Just nodeRef) False push- u2 <- runListen l2 (Just nodeRef) False push+ unlistener <- later $ do+ u1 <- linkedListen ea (Just nodeRef) False push+ u2 <- linkedListen eb (Just nodeRef) False push return (u1 >> u2) addCleanup_Listen unlistener l -- | Unwrap Just values, and discard event occurrences with Nothing values.-filterJust :: Event (Maybe a) -> Event a-filterJust ema = Event gl cacheRef+filterJust :: Event (Maybe a) -> Event a+filterJust ema = Event gl cacheRef (dep ema) where cacheRef = unsafeNewIORef Nothing ema gl = do- (l', push, nodeRef) <- ioReactive newEventImpl- l <- getListen ema- unlistener <- unlistenize $ runListen l (Just nodeRef) False $ \ma -> case ma of+ (l, push, nodeRef) <- ioReactive newEventImpl+ unlistener <- later $ linkedListen ema (Just nodeRef) False $ \ma -> case ma of Just a -> push a Nothing -> return ()- addCleanup_Listen unlistener l'+ addCleanup_Listen unlistener l -- | Create a behavior with the specified initial value, that gets updated -- by the values coming through the event. The \'current value\' of the behavior -- is notionally the value as it was 'at the start of the transaction'. -- That is, state updates caused by event firings get processed at the end of -- the transaction.-hold :: a -> Event a -> Reactive (Behavior a)+hold :: a -> Event a -> Reactive (Behavior a) hold initA ea = do bsRef <- ioReactive $ newIORef $ initA `seq` BehaviorState initA Nothing- unlistener <- unlistenize $ linkedListen ea Nothing False $ \a -> do+ unlistener <- later $ linkedListen ea Nothing False $ \a -> do bs <- ioReactive $ readIORef bsRef ioReactive $ writeIORef bsRef $ a `seq` bs { bsUpdate = Just a } when (isNothing (bsUpdate bs)) $ scheduleLast $ ioReactive $ do bs <- readIORef bsRef let newCurrent = fromJust (bsUpdate bs) writeIORef bsRef $ newCurrent `seq` BehaviorState newCurrent Nothing- sample <- ioReactive $ addCleanup_Sample unlistener (Sample $ return $ bsCurrent <$> readIORef bsRef)+ sample <- ioReactive $ addCleanup_Sample unlistener+ (Sample (bsCurrent <$> readIORef bsRef) (dep ea)) let beh = sample `seq` Behavior {- underlyingEvent = ea,- behSample = sample+ changes_ = ea,+ sampleImpl = sample } return beh --- | An event that gives the updates for the behavior. It doesn't do any equality--- comparison as the name might imply.-changes :: Behavior a -> Event a-changes = underlyingEvent- -- | An event that is guaranteed to fire once when you listen to it, giving -- the current value of the behavior, and thereafter behaves like 'changes', -- firing for each update to the behavior's value.-values :: Behavior a -> Event a-values = eventify . listenValueRaw+values :: Behavior a -> Event a+values ba = sa `seq` ea `seq` eventify (listenValueRaw ba) (dep (sa, ea))+ where+ sa = sampleImpl ba+ ea = changes ba -- | Sample the behavior at the time of the event firing. Note that the 'current value' -- of the behavior that's sampled is the value as at the start of the transaction -- before any state changes of the current transaction are applied through 'hold's.-snapshotWith :: (a -> b -> c) -> Event a -> Behavior b -> Event c-snapshotWith f ea bb = Event gl cacheRef+snapshotWith :: (a -> b -> c) -> Event a -> Behavior b -> Event c+snapshotWith f ea bb = sample' `seq` Event gl cacheRef (dep (ea, sample)) where cacheRef = unsafeNewIORef Nothing bb+ sample = sampleImpl bb+ sample' = unSample sample gl = do (l, push, nodeRef) <- ioReactive newEventImpl- sample' <- ioReactive $ unSample_ $ behSample $ bb- _ <- ioReactive $ touch sample'- unlistener <- unlistenize $ do- unlisten <- linkedListen ea (Just nodeRef) False $ \a -> do- b <- ioReactive $ sample'+ unlistener <- later $ linkedListen ea (Just nodeRef) False $ \a -> do+ b <- ioReactive sample' push (f a b)- return ()- return (unlisten >> touch bb) addCleanup_Listen unlistener l -- | Unwrap an event inside a behavior to give a time-varying event implementation.-switchE :: Behavior (Event a) -> Event a-switchE bea = Event gl cacheRef+switchE :: Behavior (Event a) -> Event a+switchE bea = eea `seq` Event gl cacheRef (dep (eea, depRef)) where+ eea = changes bea cacheRef = unsafeNewIORef Nothing bea+ depRef = unsafeNewIORef undefined bea gl = do (l, push, nodeRef) <- ioReactive newEventImpl unlisten2Ref <- ioReactive $ newIORef Nothing let doUnlisten2 = do mUnlisten2 <- readIORef unlisten2Ref fromMaybe (return ()) mUnlisten2- unlistener1 <- unlistenize $ do+ unlistener1 <- later $ do initEa <- sample bea (ioReactive . writeIORef unlisten2Ref) =<< (Just <$> linkedListen initEa (Just nodeRef) False push)- unlisten1 <- linkedListen (changes bea) (Just nodeRef) False $ \ea -> scheduleLast $ do- ioReactive doUnlisten2+ unlisten1 <- linkedListen eea (Just nodeRef) False $ \ea -> scheduleLast $ do+ ioReactive $ do+ doUnlisten2+ writeIORef depRef ea (ioReactive . writeIORef unlisten2Ref) =<< (Just <$> linkedListen ea (Just nodeRef) True push) return $ unlisten1 >> doUnlisten2 addCleanup_Listen unlistener1 l -- | Unwrap a behavior inside another behavior to give a time-varying behavior implementation.-switch :: Behavior (Behavior a) -> Reactive (Behavior a)+switch :: Behavior (Behavior a) -> Reactive (Behavior a) switch bba = do ba <- sample bba+ depRef <- ioReactive $ newIORef ba za <- sample ba- (ev, push, nodeRef) <- ioReactive newEventLinked+ let eba = changes bba+ ioReactive $ evaluate eba+ (ev, push, nodeRef) <- ioReactive $ newEventLinked (dep (bba, depRef)) unlisten2Ref <- ioReactive $ newIORef Nothing let doUnlisten2 = do mUnlisten2 <- readIORef unlisten2Ref fromMaybe (return ()) mUnlisten2 unlisten1 <- listenValueRaw bba (Just nodeRef) False $ \ba -> do- ioReactive doUnlisten2+ ioReactive $ do+ doUnlisten2+ writeIORef depRef ba (ioReactive . writeIORef unlisten2Ref . Just) =<< listenValueRaw ba (Just nodeRef) False push- hold za (finalizeEvent ev (unlisten1 >> doUnlisten2))+ hold za $ finalizeEvent ev (unlisten1 >> doUnlisten2) -- | Execute the specified 'Reactive' action inside an event.-execute :: Event (Reactive a) -> Event a-execute ev = Event gl cacheRef+execute :: Event (Reactive a) -> Event a+execute ev = Event gl cacheRef (dep ev) where cacheRef = unsafeNewIORef Nothing ev gl = do- (l', push, nodeRef) <- ioReactive newEventImpl- l <- getListen ev- unlistener <- unlistenize $ runListen l (Just nodeRef) False $ \action -> action >>= push- addCleanup_Listen unlistener l'+ (l, push, nodeRef) <- ioReactive newEventImpl+ unlistener <- later $ linkedListen ev (Just nodeRef) False $ \action -> action >>= push+ addCleanup_Listen unlistener l -- | Obtain the current value of a behavior.-sample :: Behavior a -> Reactive a-sample b = ioReactive . unSample . behSample $ b+sample :: Behavior a -> Reactive a+{-# NOINLINE sample #-}+sample = ioReactive . unSample . sampleImpl -- | If there's more than one firing in a single transaction, combine them into -- one using the specified combining function.@@ -341,15 +349,14 @@ -- input of the combining function. In most common cases it's best not to -- make any assumptions about the ordering, and the combining function would -- ideally be commutative.-coalesce :: (a -> a -> a) -> Event a -> Event a-coalesce combine e = Event gl cacheRef+coalesce :: (a -> a -> a) -> Event a -> Event a+coalesce combine e = Event gl cacheRef (dep e) where cacheRef = unsafeNewIORef Nothing e gl = do- l1 <- getListen e (l, push, nodeRef) <- ioReactive newEventImpl outRef <- ioReactive $ newIORef Nothing - unlistener <- unlistenize $ runListen l1 (Just nodeRef) False $ \a -> do+ unlistener <- later $ linkedListen e (Just nodeRef) False $ \a -> do first <- isNothing <$> ioReactive (readIORef outRef) ioReactive $ modifyIORef outRef $ \ma -> Just $ case ma of Just a0 -> a0 `combine` a@@ -362,16 +369,15 @@ -- | Throw away all event occurrences except for the first one. once :: Event a -> Event a-once e = Event gl cacheRef+once e = Event gl cacheRef (dep e) where cacheRef = unsafeNewIORef Nothing e gl = do- l1 <- getListen e (l, push, nodeRef) <- ioReactive newEventImpl aliveRef <- ioReactive $ newIORef True- unlistener <- unlistenize $ do+ unlistener <- later $ do rec- unlisten <- runListen l1 (Just nodeRef) False $ \a -> do+ unlisten <- linkedListen e (Just nodeRef) False $ \a -> do alive <- ioReactive $ readIORef aliveRef when alive $ do ioReactive $ writeIORef aliveRef False@@ -438,15 +444,15 @@ count = R.count class PriorityQueueable k where- priorityOf :: k -> IO Int64+ priorityOf :: k -> IO Int64 newtype Sequence = Sequence Int64 deriving (Eq, Ord, Enum) data PriorityQueue k v = PriorityQueue {- pqNextSeq :: IORef Sequence,- pqDirty :: IORef Bool,- pqQueue :: IORef (Map (Int64, Sequence) v),- pqData :: IORef (Map Sequence (k, v))+ pqNextSeq :: IORef Sequence,+ pqDirty :: IORef Bool,+ pqQueue :: IORef (Map (Int64, Sequence) v),+ pqData :: IORef (Map Sequence (k, v)) } newPriorityQueue :: IO (PriorityQueue k v)@@ -494,9 +500,9 @@ priorityOf Nothing = return maxBound data ReactiveState = ReactiveState {- asQueue1 :: Seq (Reactive ()),- asQueue2 :: PriorityQueue (Maybe (MVar Node)) (Reactive ()),- asFinal :: Seq (Reactive ())+ asQueue1 :: Seq (Reactive ()),+ asQueue2 :: PriorityQueue (Maybe (MVar Node)) (Reactive ()),+ asFinal :: Seq (Reactive ()) } instance Functor (R.Reactive Plain) where@@ -537,17 +543,9 @@ data Listen a = Listen { runListen_ :: Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) } -runListen :: Listen a -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())-{-# NOINLINE runListen #-}-runListen l mv suppressEarlierFirings handle = do- unlisten <- runListen_ l mv suppressEarlierFirings handle- -- ensure l doesn't get cleaned up while runListen_ is running- _ <- ioReactive $ touch l- return unlisten- -- | Unwrap an event's listener machinery. getListen :: Event a -> Reactive (Listen a)-getListen (Event getLRaw cacheRef) = do+getListen (Event getLRaw cacheRef _) = do mL <- ioReactive $ readIORef cacheRef case mL of Just l -> return l@@ -559,9 +557,14 @@ -- | Listen for firings of this event. The returned @IO ()@ is an IO action -- that unregisters the listener. This is the observer pattern. linkedListen :: Event a -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())-linkedListen ev mMvTarget suppressEarlierFirings handle = do+{-# NOINLINE linkedListen #-}+linkedListen ev mv suppressEarlierFirings handle = do+ ioReactive $ evaluate ev l <- getListen ev- runListen l mMvTarget suppressEarlierFirings handle+ unlisten <- runListen_ l mv suppressEarlierFirings handle+ -- ensure l doesn't get cleaned up while runListen_ is running+ _ <- ioReactive $ touch l+ return unlisten -- | Variant of 'listen' that allows you to initiate more activity in the current -- transaction. Useful for implementing new primitives.@@ -623,6 +626,11 @@ let listeners' = M.delete iD (noListeners no) return $ listeners' `seq` no { noListeners = listeners' } +data Dep = Dep Any++dep :: a -> Dep+dep = Dep . unsafeCoerce+ -- | Returns a 'Listen' for registering listeners, and a push action for pushing -- a value into the event. newEventImpl :: forall p a . IO (Listen a, a -> Reactive (), MVar Node)@@ -644,7 +652,7 @@ let listeners' = M.delete iD (obListeners ob) return $ listeners' `seq` ob { obListeners = listeners' } unlinkNode nodeRef iD- touch listen+ --touch listen return () return (ob', (reverse . obFirings $ ob, unlisten, iD)) modified <- case mMvTarget of@@ -667,34 +675,37 @@ return (listen, push, nodeRef) -- | Returns an event, and a push action for pushing a value into the event.-newEventLinked :: IO (Event a, a -> Reactive (), MVar Node)-newEventLinked = do+newEventLinked :: Dep -> IO (Event a, a -> Reactive (), MVar Node)+newEventLinked d = do (listen, push, nodeRef) <- newEventImpl cacheRef <- newIORef Nothing let ev = Event { getListenRaw = return listen,- evCacheRef = cacheRef+ evCacheRef = cacheRef,+ eDep = d } return (ev, push, nodeRef) instance Functor (R.Event Plain) where- f `fmap` e = Event getListen' cacheRef+ f `fmap` e = Event getListen' cacheRef (dep e) where cacheRef = unsafeNewIORef Nothing e- getListen' = do+ getListen' = return $ Listen $ \mNodeRef suppressEarlierFirings handle -> do- l <- getListen e- runListen l mNodeRef suppressEarlierFirings (handle . f)+ linkedListen e mNodeRef suppressEarlierFirings (handle . f) instance Functor (R.Behavior Plain) where- f `fmap` Behavior underlyingEvent sample =- sample' `seq` Behavior (f `fmap` underlyingEvent) sample'- where sample' = Sample $ return $ f `fmap` unSample sample+ f `fmap` Behavior e s =+ fs `seq` fe `seq` Behavior fe fs+ where+ fe = f `fmap` e+ s' = unSample s+ fs = s' `seq` Sample (f `fmap` s') (dep s) constant :: a -> Behavior a constant a = Behavior {- underlyingEvent = never,- behSample = Sample $ return $ return a+ changes_ = never,+ sampleImpl = Sample (return a) undefined } data BehaviorState a = BehaviorState {@@ -705,7 +716,7 @@ -- | Add a finalizer to an event. finalizeEvent :: Event a -> IO () -> Event a {-# NOINLINE finalizeEvent #-}-finalizeEvent ea unlisten = Event gl (evCacheRef ea)+finalizeEvent ea unlisten = ea { getListenRaw = gl } where gl = do l <- getListen ea@@ -727,10 +738,10 @@ newtype Unlistener = Unlistener (MVar (Maybe (IO ()))) --- | Listen to an input event/behavior and return an 'Unlistener' that can be--- attached to an output event using 'addCleanup_Listen'.-unlistenize :: Reactive (IO ()) -> Reactive Unlistener-unlistenize doListen = do+-- | Perform a listen later so we can tolerate lazy loops.+-- Returns an 'Unlistener' that can be attached to an event with 'addCleanup_Listen'.+later :: Reactive (IO ()) -> Reactive Unlistener+later doListen = do unlistener@(Unlistener ref) <- newUnlistener -- We schedule the actual listen rather than doing it now, so event values get -- evaluated lazily. Otherwise we get deadlocks when events are used in value loops.@@ -746,7 +757,7 @@ newUnlistener :: Reactive Unlistener newUnlistener = Unlistener <$> ioReactive (newMVar (Just $ return ())) --- | Cause the things listened to with unlistenize to be unlistened when the+-- | Cause the things listened to with 'later' to be unlistened when the -- specified listener is not referenced any more. addCleanup_Listen :: Unlistener -> Listen a -> Reactive (Listen a) addCleanup_Listen (Unlistener ref) l = ioReactive $ finalizeListen l $ do@@ -754,8 +765,10 @@ fromMaybe (return ()) mUnlisten putMVar ref Nothing +-- | Cause the things listened to with 'later' to be unlistened when the+-- specified sample is not referenced any more. addCleanup_Sample :: Unlistener -> Sample a -> IO (Sample a)-addCleanup_Sample (Unlistener ref) r = finalizeSample r $ do+addCleanup_Sample (Unlistener ref) s = finalizeSample s $ do mUnlisten <- takeMVar ref fromMaybe (return ()) mUnlisten putMVar ref Nothing@@ -768,7 +781,7 @@ listenValueRaw ba = lastFiringOnly $ \mNodeRef suppressEarlierFirings handle -> do a <- sample ba handle a- linkedListen (underlyingEvent ba) mNodeRef suppressEarlierFirings handle+ linkedListen (changes ba) mNodeRef suppressEarlierFirings handle -- | Queue the specified atomic to run at the end of the priority 2 queue schedulePrioritized :: Maybe (MVar Node)@@ -784,7 +797,7 @@ lift $ dirtyPriorityQueue q -- Clean up the listener so it gives only one value per transaction, specifically--- the last one. +-- the last one. lastFiringOnly :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) lastFiringOnly listen mNodeRef suppressEarlierFirings handle = do@@ -797,39 +810,39 @@ ioReactive $ writeIORef aRef Nothing handle a -eventify :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Event a-eventify listen = Event gl cacheRef+eventify :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Dep -> Event a+eventify listen d = Event gl cacheRef d where cacheRef = unsafeNewIORef Nothing listen gl = do (l, push, nodeRef) <- ioReactive newEventImpl- unlistener <- unlistenize $ listen (Just nodeRef) False push+ unlistener <- later $ listen (Just nodeRef) False push addCleanup_Listen unlistener l instance Applicative (R.Behavior Plain) where pure = constant- Behavior u1 s1 <*> Behavior u2 s2 = Behavior u s+ b1@(Behavior e1 s1) <*> b2@(Behavior e2 s2) = Behavior u s where cacheRef = unsafeNewIORef Nothing s2- u = Event gl cacheRef+ u = Event gl cacheRef (dep (e1,e2))+ s1' = unSample s1+ s2' = unSample s2 gl = do fRef <- ioReactive $ newIORef =<< unSample s1 aRef <- ioReactive $ newIORef =<< unSample s2- l1 <- getListen u1- l2 <- getListen u2 (l, push, nodeRef) <- ioReactive newEventImpl- unlistener <- unlistenize $ do- un1 <- runListen l1 (Just nodeRef) False $ \f -> do+ unlistener <- later $ do+ un1 <- linkedListen e1 (Just nodeRef) False $ \f -> do ioReactive $ writeIORef fRef f a <- ioReactive $ readIORef aRef push (f a)- un2 <- runListen l2 (Just nodeRef) False $ \a -> do+ un2 <- linkedListen e2 (Just nodeRef) False $ \a -> do f <- ioReactive $ readIORef fRef ioReactive $ writeIORef aRef a push (f a) return (un1 >> un2) addCleanup_Listen unlistener l- s = Sample $ return $ ($) <$> unSample s1 <*> unSample s2+ s = s1' `seq` s2' `seq` Sample (($) <$> s1' <*> s2') (dep (s1, s2)) {- -- | Cross the specified event over to a different partition.@@ -843,7 +856,7 @@ cross :: (Typeable p, Typeable q) => Behavior a -> Reactive (Behavior q a) cross bpa = do a <- sample bpa- ea <- crossE (underlyingEvent bpa)+ ea <- crossE (changes bpa) ioReactive $ sync $ 3 a ea -}