sodium 0.5.0.1 → 0.5.0.2

raw patch · 16 files changed

+895/−643 lines, 16 filesdep ~basedep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• examples/games/Engine.hs +2/−1
• examples/games/Image.hs +2/−2
• examples/tests.hs +0/−538
• examples/tests/README.txt +18/−0
• examples/tests/memory-test-1.hs +24/−0
• examples/tests/memory-test-2.hs +35/−0
• examples/tests/memory-test-3.hs +21/−0
• examples/tests/memory-test-4.hs +20/−0
• examples/tests/memory-test-5.hs +18/−0
• examples/tests/memory-test-6.hs +27/−0
• examples/tests/unit-tests.hs +538/−0
• sodium.cabal +14/−6
• src/FRP/Sodium.hs +2/−1
• src/FRP/Sodium/Context.hs +12/−0
• src/FRP/Sodium/Internal.hs +5/−1
• src/FRP/Sodium/Plain.hs +157/−94

@@ -77,7 +77,7 @@     (eMouse, pushMouse) <- sync newEvent     (eTime, pushTime) <- sync newEvent     spritesRef <- newIORef []-    _ <- sync $ do+    unlisten <- sync $ do         time <- hold 0 eTime         sprites <- game eMouse time         listen (values sprites) (writeIORef spritesRef)@@ -113,6 +113,7 @@         )     GLUT.addTimerCallback (1000 `div` frameRate) $ repaint     GLUT.mainLoop+    unlisten   where     toScreen :: GLint -> GLint -> IO (Coord, Coord)     toScreen x y = do

@@ -67,9 +67,9 @@ unsafeTextureToBS (TextureImage iWidth iHeight pWidth pHeight fmt buf) = do     let bpp = bytesPerPixel fmt         sz = bpp * iWidth * iHeight-    bytes <- peekArray sz buf+    bytes <- B.create sz $ \str -> B.memcpy str buf (fromIntegral sz)     free buf-    return $ TextureImage iWidth iHeight pWidth pHeight fmt (B.pack bytes)+    return $ TextureImage iWidth iHeight pWidth pHeight fmt bytes  bytesPerPixel :: Format -> Int bytesPerPixel RGB = 3

@@ -1,538 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, DoRec #-}-import FRP.Sodium-import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Data.Char-import Data.IORef-import Test.HUnit--event1 = TestCase $ do-    (ev, push) <- sync newEvent-    outRef <- newIORef ""-    sync $ do-        push '?'-    unlisten <- sync $ do-        push 'h'-        unlisten <- listen ev $ \letter -> modifyIORef outRef (++ [letter]) -        push 'e'-        return unlisten-    sync $ do-        push 'l'-        push 'l'-        push 'o'-    unlisten-    sync $ do-        push '!'-    out <- readIORef outRef-    assertEqual "event1" "hello" =<< readIORef outRef--fmap1 = TestCase $ do-    (ev, push) <- sync newEvent-    outRef <- newIORef ""-    sync $ do-        listen (toUpper `fmap` ev) $ \letter -> modifyIORef outRef (++ [letter])-        push 'h'-        push 'e'-        push 'l'-        push 'l'-        push 'o'-    out <- readIORef outRef-    assertEqual "fmap1" "HELLO" =<< readIORef outRef--merge1 = TestCase $ do-    (ev1, push1) <- sync newEvent-    (ev2, push2) <- sync newEvent-    let ev = merge ev1 ev2-    outRef <- newIORef []-    unlisten <- sync $ listen ev $ \a -> modifyIORef outRef (++ [a])-    sync $ do-        push1 "hello"-        push2 "world"-    sync $ push1 "people"-    sync $ push1 "everywhere"-    unlisten-    assertEqual "merge1" ["hello","world","people","everywhere"] =<< readIORef outRef--filterJust1 = TestCase $ do-    (ema, push) <- sync newEvent-    outRef <- newIORef []-    sync $ do-        listen (filterJust ema) $ \a -> modifyIORef outRef (++ [a])-        push (Just "yes")-        push Nothing-        push (Just "no")-    assertEqual "filterJust1" ["yes", "no"] =<< readIORef outRef--filterE1 = TestCase $ do-    (ec, push) <- sync newEvent-    outRef <- newIORef ""-    sync $ do-        let ed = filterE isDigit ec-        listen ed $ \a -> modifyIORef outRef (++ [a])-        push 'a'-        push '2'-        push 'X'-        push '3'-    assertEqual "filterE1" "23" =<< readIORef outRef--gate1 = TestCase $ do-    (c, pushc) <- sync newEvent-    (pred, pushPred) <- sync $ newBehavior True-    outRef <- newIORef []-    unlisten <- sync $ listen (gate c pred) $ \a -> modifyIORef outRef (++ [a])-    sync $ pushc 'H'-    sync $ pushPred False-    sync $ pushc 'O'-    sync $ pushPred True-    sync $ pushc 'I'-    unlisten-    assertEqual "gate1" "HI" =<< readIORef outRef--beh1 = TestCase $ do-    outRef <- newIORef []-    (push, unlisten) <- sync $ do-        (beh, push) <- newBehavior "init"-        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])-        return (push, unlisten)-    sync $ do-        push "next"-    unlisten-    assertEqual "beh1" ["init", "next"] =<< readIORef outRef--beh2 = TestCase $ do-    outRef <- newIORef []-    (push, unlisten) <- sync $ do-        (beh, push) <- newBehavior "init"-        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])-        return (push, unlisten)-    unlisten-    sync $ do-        push "next"-    assertEqual "beh2" ["init"] =<< readIORef outRef--beh3 = TestCase $ do-    outRef <- newIORef []-    (push, unlisten) <- sync $ do-        (beh, push) <- newBehavior "init"-        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])-        return (push, unlisten)-    sync $ do-        push "first"-        push "second"-    unlisten-    assertEqual "beh3" ["init", "second"] =<< readIORef outRef---- | This demonstrates the fact that if there are multiple updates to a behaviour--- in a given transaction, the last one prevails.-beh4 = TestCase $ do-    outRef <- newIORef []-    (push, unlisten) <- sync $ do-        (beh, push) <- newBehavior "init"-        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])-        push "other"-        return (push, unlisten)-    sync $ do-        push "first"-        push "second"-    unlisten-    assertEqual "beh4" ["other", "second"] =<< readIORef outRef--beh5 = TestCase $ do-    (ea, push) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        beh <- hold "init" ea-        unlisten <- listen (map toUpper <$> values beh) $ \a -> modifyIORef outRef (++ [a])-        push "other"-        return unlisten-    sync $ do-        push "first"-        push "second"-    unlisten-    assertEqual "beh5" ["OTHER", "SECOND"] =<< readIORef outRef--behConstant = TestCase $ do-    outRef <- newIORef []-    unlisten <- sync $ listen (values $ pure 'X') $ \a -> modifyIORef outRef (++ [a])-    unlisten-    assertEqual "behConstant" ['X'] =<< readIORef outRef--valuesThenMap = TestCase $ do-    (b, push) <- sync $ newBehavior 9-    outRef <- newIORef []-    unlisten <- sync $ listen (values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push (2 :: Int)-    sync $ push 7-    unlisten-    assertEqual "valuesThenMap" [109,102,107] =<< readIORef outRef ---- | This is used for tests where values() produces a single initial value on listen,--- and then we double that up by causing that single initial event to be repeated.--- This needs testing separately, because the code must be done carefully to achieve-doubleUp :: Event a -> Event a-doubleUp e = merge e e--valuesTwiceThenMap = TestCase $ do-    (b, push) <- sync $ newBehavior 9-    outRef <- newIORef []-    unlisten <- sync $ listen (doubleUp . values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push (2 :: Int)-    sync $ push 7-    unlisten-    assertEqual "valuesThenMap" [109,109,102,102,107,107] =<< readIORef outRef -    -valuesThenCoalesce = TestCase $ do-    (b, push) <- sync $ newBehavior 9-    outRef <- newIORef []-    unlisten <- sync $ listen (coalesce (\_ x -> x) . values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenCoalesce" [9,2,7] =<< readIORef outRef--valuesTwiceThenCoalesce = TestCase $ do-    (b, push) <- sync $ newBehavior 9-    outRef <- newIORef []-    unlisten <- sync $ listen (coalesce (+) . doubleUp. values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenCoalesce" [18,4,14] =<< readIORef outRef--valuesThenSnapshot = TestCase $ do-    (bi, pushi) <- sync $ newBehavior (9 :: Int)-    (bc, pushc) <- sync $ newBehavior 'a'-    outRef <- newIORef []-    unlisten <- sync $ listen (flip snapshot bc . values $ bi) $ \a -> modifyIORef outRef (++ [a])-    sync $ pushc 'b'-    sync $ pushi 2-    sync $ pushc 'c'-    sync $ pushi 7-    unlisten-    assertEqual "valuesThenSnapshot" ['a','b','c'] =<< readIORef outRef--valuesTwiceThenSnapshot = TestCase $ do-    (bi, pushi) <- sync $ newBehavior (9 :: Int)-    (bc, pushc) <- sync $ newBehavior 'a'-    outRef <- newIORef []-    unlisten <- sync $ listen (flip snapshot bc . doubleUp . values $ bi) $ \a -> modifyIORef outRef (++ [a])-    sync $ pushc 'b'-    sync $ pushi 2-    sync $ pushc 'c'-    sync $ pushi 7-    unlisten-    assertEqual "valuesThenSnapshot" ['a','a','b','b','c','c'] =<< readIORef outRef--valuesThenMerge = TestCase $ do-    (bi, pushi) <- sync $ newBehavior (9 :: Int)-    (bj, pushj) <- sync $ newBehavior (2 :: Int)-    outRef <- newIORef []-    unlisten <- sync $ listen (mergeWith (+) (values bi) (values bj)) $ \a -> modifyIORef outRef (++ [a])-    sync $ pushi 1-    sync $ pushj 4-    unlisten-    assertEqual "valuesThenMerge" [11,1,4] =<< readIORef outRef --valuesThenFilter = TestCase $ do-    (b, push) <- sync $ newBehavior (9 :: Int)-    outRef <- newIORef []-    unlisten <- sync $ listen (filterE (const True) . values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenFilter" [9,2,7] =<< readIORef outRef--valuesTwiceThenFilter = TestCase $ do-    (b, push) <- sync $ newBehavior (9 :: Int)-    outRef <- newIORef []-    unlisten <- sync $ listen (filterE (const True) . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenFilter" [9,9,2,2,7,7] =<< readIORef outRef--valuesThenOnce = TestCase $ do-    (b, push) <- sync $ newBehavior (9 :: Int)-    outRef <- newIORef []-    unlisten <- sync $ listen (once . values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenOnce" [9] =<< readIORef outRef--valuesTwiceThenOnce = TestCase $ do-    (b, push) <- sync $ newBehavior (9 :: Int)-    outRef <- newIORef []-    unlisten <- sync $ listen (once . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 7-    unlisten-    assertEqual "valuesThenOnce" [9] =<< readIORef outRef-    --- | Test values being "executed" before listen. Somewhat redundant since this is--- Haskell and "values b" is pure.-valuesLateListen = TestCase $ do-    (b, push) <- sync $ newBehavior (9 :: Int)-    outRef <- newIORef []-    let bv = values b-    sync $ push 8-    unlisten <- sync $ listen bv $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    unlisten-    assertEqual "valuesLateListen" [8,2] =<< readIORef outRef--appl1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    ba <- sync $ hold 0 ea-    (eb, pushb) <- sync newEvent-    bb <- sync $ hold 0 eb-    let esum = (+) <$> ba <*> bb-    outRef <- newIORef []-    unlisten <- sync $ listen (values esum) $ \sum -> modifyIORef outRef (++ [sum])-    sync $ pusha 5-    sync $ pushb 100-    sync $ pusha 10 >> pushb 200-    unlisten-    assertEqual "appl1" [0, 5, 105, 210] =<< readIORef outRef-    -snapshot1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    (eb, pushb) <- sync newEvent-    bb <- sync $ hold 0 eb-    let ec = snapshotWith (,) ea bb-    outRef <- newIORef []-    unlisten <- sync $ listen ec $ \c -> modifyIORef outRef (++ [c])-    sync $ pusha 'A'-    sync $ pushb 50-    sync $ pusha 'B'-    sync $ pusha 'C' >> pushb 60-    sync $ pusha 'D'-    unlisten-    assertEqual "snapshot1" [('A',0),('B',50),('C',50),('D',60)] =<< readIORef outRef--holdIsDelayed = TestCase $ do-    (e, push) <- sync newEvent-    h <- sync $ hold (0 :: Int) e-    let pair = snapshotWith (\a b -> show a ++ " " ++ show b) e h-    outRef <- newIORef []-    unlisten <- sync $ listen pair $ \a -> modifyIORef outRef (++ [a])-    sync $ push 2-    sync $ push 3-    unlisten-    assertEqual "holdIsDelayed" ["2 0", "3 2"] =<< readIORef outRef--count1 = TestCase $ do-    (ea, push) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        eCount <- countE ea-        listen eCount $ \c -> modifyIORef outRef (++ [c])-    sync $ push ()-    sync $ push ()-    sync $ push ()-    unlisten-    assertEqual "count1" [1,2,3] =<< readIORef outRef--collect1 = TestCase $ do-    (ea, push) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        ba <- hold 100 ea-        sum <- collect (\a s -> (a+s, a+s)) 0 ba-        listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])-    sync $ push 5-    sync $ push 7-    sync $ push 1-    sync $ push 2-    sync $ push 3-    unlisten-    assertEqual "collect1" [100, 105, 112, 113, 115, 118] =<< readIORef outRef--collect2 = TestCase $ do-    outRef <- newIORef []-    -- This is a bit of an edge case.-    (unlisten, push) <- sync $ do-        (ba, push) <- newBehavior 100-        sum <- collect (\a s -> (a + s, a + s)) 0 ba-        push 5-        unlisten <- listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])-        return (unlisten, push)-    sync $ push 7-    sync $ push 1-    unlisten-    assertEqual "collect2" [105, 112, 113] =<< readIORef outRef--collectE1 = TestCase $ do-    (ea, push) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        sum <- collectE (\a s -> (a+s, a+s)) 100 ea-        listen sum $ \sum -> modifyIORef outRef (++ [sum])-    sync $ push 5-    sync $ push 7-    sync $ push 1-    sync $ push 2-    sync $ push 3-    unlisten-    assertEqual "collectE1" [105, 112, 113, 115, 118] =<< readIORef outRef--collectE2 = TestCase $ do-    (ea, push) <- sync newEvent-    outRef <- newIORef []-    -- This behaviour is a little bit odd but difficult to fix in the-    -- implementation. However, it shouldn't be too much of a problem in-    -- practice. Here we are defining it.-    unlisten <- sync $ do-        sum <- collectE (\a s -> (a + s, a + s)) 100 ea-        push 5-        listen sum $ \sum -> modifyIORef outRef (++ [sum])-    sync $ push 7-    sync $ push 1-    unlisten-    assertEqual "collectE2" [105, 112, 113] =<< readIORef outRef--switchE1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    (eb, pushb) <- sync newEvent-    (esw, pushsw) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        sw <- hold ea esw-        let eo = switchE sw-        unlisten <- listen eo $ \o -> modifyIORef outRef (++ [o])-        pusha 'A'-        pushb 'a'-        return unlisten-    sync $ pusha 'B' >> pushb 'b'-    sync $ pushsw eb >> pusha 'C' >> pushb 'c'-    sync $ pusha 'D' >> pushb 'd'-    sync $ pusha 'E' >> pushb 'e' >> pushsw ea-    sync $ pusha 'F' >> pushb 'f'-    sync $ pusha 'G' >> pushb 'g' >> pushsw eb-    sync $ pusha 'H' >> pushb 'h' >> pushsw ea-    sync $ pusha 'I' >> pushb 'i' >> pushsw ea-    unlisten-    assertEqual "switchE1" "ABCdeFGhI" =<< readIORef outRef--switch1 = TestCase $ do-    outRef <- newIORef []-    (ba, bb, pusha, pushb, pushsw, unlisten) <- sync $ do-        (ba, pusha) <- newBehavior 'A'-        (bb, pushb) <- newBehavior 'a'-        (bsw, pushsw) <- newBehavior ba-        bo <- switch bsw-        unlisten <- listen (values bo) $ \o -> modifyIORef outRef (++ [o])-        return (ba, bb, pusha, pushb, pushsw, unlisten)-    sync $ pusha 'B' >> pushb 'b'-    sync $ pushsw bb >> pusha 'C' >> pushb 'c'-    sync $ pusha 'D' >> pushb 'd'-    sync $ pusha 'E' >> pushb 'e' >> pushsw ba-    sync $ pusha 'F' >> pushb 'f'-    sync $ pushsw bb-    sync $ pushsw ba-    sync $ pusha 'G' >> pushb 'g' >> pushsw bb-    sync $ pusha 'H' >> pushb 'h' >> pushsw ba-    sync $ pusha 'I' >> pushb 'i' >> pushsw ba-    unlisten-    assertEqual "switch1" "ABcdEFfFgHI" =<< readIORef outRef-    -once1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        listen (once ea) $ \a -> modifyIORef outRef (++ [a])-    sync $ pusha 'A'-    sync $ pusha 'B'-    sync $ pusha 'C'-    unlisten-    assertEqual "switch1" "A" =<< readIORef outRef--once2 = TestCase $ do-    (ea, pusha) <- sync newEvent-    outRef <- newIORef []-    unlisten <- sync $ do-        pusha 'A'-        listen (once ea) $ \a -> modifyIORef outRef (++ [a])-    sync $ pusha 'B'-    sync $ pusha 'C'-    unlisten-    assertEqual "switch1" "A" =<< readIORef outRef--data Page = Page { unPage :: Reactive (Char, Event Page) }--cycle1 = TestCase $ do-    outRef <- newIORef []-    (ep, push) <- sync newEvent-    bo <- sync $ do-        let initPair = ('a', ep)-        rec-            bPair <- hold initPair ePage-            let ePage = execute $ unPage <$> switchE (snd <$> bPair)-        return (fst <$> bPair)-    unlisten <- sync $ listen (values bo) $ \o -> modifyIORef outRef (++ [o])-    sync $ push (Page $ return ('b', ep))-    sync $ push (Page $ return ('c', ep))-    unlisten-    assertEqual "cycle1" "abc" =<< readIORef outRef--mergeWith1 = TestCase $ do-    outRef <- newIORef []-    (ea, pushA) <- sync newEvent-    (eb, pushB) <- sync newEvent-    unlisten <- sync $ do-        pushA 5-        listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])-    sync $ pushA 2-    sync $ pushB 3-    sync $ pushA 10 >> pushB 4-    sync $ pushB 7 >> pushA 1-    unlisten-    assertEqual "mergeWith1" [5,2,3,14,8] =<< readIORef outRef--mergeWith2 = TestCase $ do-    outRef <- newIORef []-    (ea, pushA) <- sync newEvent-    (eb, pushB) <- sync newEvent-    unlisten <- sync $ do-        pushA 5-        unlisten <- listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])-        pushB 99-        return unlisten-    unlisten-    assertEqual "mergeWith2" [104] =<< readIORef outRef--mergeWith3 = TestCase $ do-    outRef <- newIORef []-    (ea, pushA) <- sync newEvent-    (eb, pushB) <- sync newEvent-    unlisten <- sync $ do-        listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])-    sync $ pushA 2-    sync $ pushB 3 >> pushB 1 >> pushA 10-    sync $ pushB 9 >> pushB 11 >> pushB 12-    sync $ pushA 32 >> pushA 11 >> pushA 12-    unlisten-    assertEqual "mergeWith3" [2,14,32,55] =<< readIORef outRef--coalesce1 = TestCase $ do-    outRef <- newIORef []-    (ea, pushA) <- sync newEvent-    (eb, pushB) <- sync newEvent-    unlisten <- sync $ do-        listen (coalesce (+) (merge ea eb)) $ \o -> modifyIORef outRef (++ [o])-    sync $ pushA 2-    sync $ pushA 5 >> pushB 6-    unlisten-    assertEqual "coalesce1" [2, 11] =<< readIORef outRef--tests = test [ event1, fmap1, merge1, filterJust1, filterE1, gate1, beh1, beh2, beh3, beh4, beh5,-    behConstant, valuesThenMap, valuesTwiceThenMap, valuesThenCoalesce, valuesTwiceThenCoalesce,-    valuesThenSnapshot, valuesTwiceThenSnapshot, valuesThenMerge, valuesThenFilter,-    valuesTwiceThenFilter, valuesThenOnce, valuesTwiceThenOnce, valuesLateListen,-    holdIsDelayed, appl1, snapshot1, count1, collect1, collect2, collectE1, collectE2, switchE1,-    switch1, once1, once2, cycle1{-, mergeWith1, mergeWith2, mergeWith3,-    coalesce1-} ]--main = {-forever $-} runTestTT tests-

@@ -0,0 +1,18 @@+Run each memory test like this:++    ghc memory-test-1.hs -prof -auto-all+    ./memory-test-1 +RTS -hc+    (interrupt it after a few seconds)+    hp2ps memory-test-1.hp+    evince memory-test-1.ps++Make sure it isn't leaking memory.++----++Another important test is to uncomment 'forever' in unit-tests.hs and run it that+way, making sure that you don't get occasional failures. This makes sure we don't+drop the ball in the memory management, which is a little tricky.++    main = forever $ runTestTT tests+

@@ -0,0 +1,24 @@+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception++verbose = False++main = do+    (et, pushT) <- sync $ newEvent+    t <- sync $ hold 0 et+    let etens = (`div` 10) <$> et+    tens <- sync $ hold 0 etens+    let changeTens = filterJust $ snapshotWith (\new old ->+            if new /= old+                then Just new+                else Nothing) etens tens+    out <- sync $ do+        oout <- hold (((,) 0) <$> t) $ (\tens -> ((,) tens) <$> t) <$> changeTens+        switch oout+    kill <- sync $ listen (values out) $ \x ->+        if verbose then print x else (evaluate x >> return ())+    mapM_ (sync . pushT) [0..]+    kill+

@@ -0,0 +1,35 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception++data Source = Source { unSource :: Reactive (Behaviour (Int, Int), Event Source) }++verbose = False++main = do+    (et, pushT) <- sync $ newEvent+    t <- sync $ hold 0 et+    let etens = (`div` 10) <$> et+    tens <- sync $ hold 0 etens+    let changeTens = filterJust $ snapshotWith (\new old ->+            if new /= old+                then Just new+                else Nothing) etens tens+    oout <- sync $ do+        let newSource = (\tens -> Source $ do+                    let out = ((,) tens) <$> t+                    return (out, newSource)+                ) <$> changeTens+            initPair = (((,) 0) <$> t, newSource)+        rec+            bPair <- hold initPair eSwitch+            let eSwitch = execute $ unSource <$> switchE (snd <$> bPair)+        return (fst <$> bPair)+    out <- sync $ switch oout+    kill <- sync $ listen (values out) $ \x ->+        if verbose then print x else (evaluate x >> return ())+    mapM_ (sync . pushT) [0..]+    kill+

@@ -0,0 +1,21 @@+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception+import Control.Monad++verbose = False++main = do+    (et, _) <- sync newEvent+    t <- sync $ hold (0 :: Int) et+    (eChange, pushC) <- sync $ newEvent+    out <- sync $ do+        oout <- hold t $ (\_ -> t) <$> eChange+        switch oout+    kill <- sync $ listen (values out) $ \x ->+        if verbose then print x else (evaluate x >> return ())+    forM_ [0..] $ \i -> do+        sync $ pushC ()+    kill+

@@ -0,0 +1,20 @@+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception+import Control.Monad++verbose = False++main = do+    (et, _) <- sync newEvent+    (eChange, pushC) <- sync $ newEvent+    out <- sync $ do+        oout <- hold et $ (\_ -> et) <$> eChange+        return $ switchE oout+    kill <- sync $ listen out $ \x ->+        if verbose then print (x :: Int) else (evaluate x >> return ())+    forM_ [0..] $ \i -> do+        sync $ pushC ()+    kill+

@@ -0,0 +1,18 @@+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception+import Control.Monad++verbose = False++main = do+    (et, _) <- sync newEvent+    (eChange, pushC) <- sync $ newEvent+    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+        sync $ pushC i+    kill+

@@ -0,0 +1,27 @@+{-# LANGUAGE DoRec #-}+-- | Make sure this program runs without leaking memory+import FRP.Sodium+import Control.Applicative+import Control.Exception+import Control.Monad++verbose = False++flam :: Event () -> Reactive (Behavior Bool)+flam e = do+    rec+        let eToggle = snapshotWith (\() selected -> not selected) e selected+        selected <- hold False eToggle+    return selected++main = do+    (e, push) <- sync newEvent+    out <- sync $ do+        eInit <- flam e+        eFlam <- hold eInit (execute ((const $ flam e) <$> e))+        switch eFlam+    kill <- sync $ listen (values out) $ \x ->+        if verbose then print x else (evaluate x >> return ())+    forever $ sync $ push ()+    kill+

@@ -0,0 +1,538 @@+{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, DoRec #-}+import FRP.Sodium+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.IORef+import Test.HUnit++event1 = TestCase $ do+    (ev, push) <- sync newEvent+    outRef <- newIORef ""+    sync $ do+        push '?'+    unlisten <- sync $ do+        push 'h'+        unlisten <- listen ev $ \letter -> modifyIORef outRef (++ [letter]) +        push 'e'+        return unlisten+    sync $ do+        push 'l'+        push 'l'+        push 'o'+    unlisten+    sync $ do+        push '!'+    out <- readIORef outRef+    assertEqual "event1" "hello" =<< readIORef outRef++fmap1 = TestCase $ do+    (ev, push) <- sync newEvent+    outRef <- newIORef ""+    sync $ do+        listen (toUpper `fmap` ev) $ \letter -> modifyIORef outRef (++ [letter])+        push 'h'+        push 'e'+        push 'l'+        push 'l'+        push 'o'+    out <- readIORef outRef+    assertEqual "fmap1" "HELLO" =<< readIORef outRef++merge1 = TestCase $ do+    (ev1, push1) <- sync newEvent+    (ev2, push2) <- sync newEvent+    let ev = merge ev1 ev2+    outRef <- newIORef []+    unlisten <- sync $ listen ev $ \a -> modifyIORef outRef (++ [a])+    sync $ do+        push1 "hello"+        push2 "world"+    sync $ push1 "people"+    sync $ push1 "everywhere"+    unlisten+    assertEqual "merge1" ["hello","world","people","everywhere"] =<< readIORef outRef++filterJust1 = TestCase $ do+    (ema, push) <- sync newEvent+    outRef <- newIORef []+    sync $ do+        listen (filterJust ema) $ \a -> modifyIORef outRef (++ [a])+        push (Just "yes")+        push Nothing+        push (Just "no")+    assertEqual "filterJust1" ["yes", "no"] =<< readIORef outRef++filterE1 = TestCase $ do+    (ec, push) <- sync newEvent+    outRef <- newIORef ""+    sync $ do+        let ed = filterE isDigit ec+        listen ed $ \a -> modifyIORef outRef (++ [a])+        push 'a'+        push '2'+        push 'X'+        push '3'+    assertEqual "filterE1" "23" =<< readIORef outRef++gate1 = TestCase $ do+    (c, pushc) <- sync newEvent+    (pred, pushPred) <- sync $ newBehavior True+    outRef <- newIORef []+    unlisten <- sync $ listen (gate c pred) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'H'+    sync $ pushPred False+    sync $ pushc 'O'+    sync $ pushPred True+    sync $ pushc 'I'+    unlisten+    assertEqual "gate1" "HI" =<< readIORef outRef++beh1 = TestCase $ do+    outRef <- newIORef []+    (push, unlisten) <- sync $ do+        (beh, push) <- newBehavior "init"+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])+        return (push, unlisten)+    sync $ do+        push "next"+    unlisten+    assertEqual "beh1" ["init", "next"] =<< readIORef outRef++beh2 = TestCase $ do+    outRef <- newIORef []+    (push, unlisten) <- sync $ do+        (beh, push) <- newBehavior "init"+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])+        return (push, unlisten)+    unlisten+    sync $ do+        push "next"+    assertEqual "beh2" ["init"] =<< readIORef outRef++beh3 = TestCase $ do+    outRef <- newIORef []+    (push, unlisten) <- sync $ do+        (beh, push) <- newBehavior "init"+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])+        return (push, unlisten)+    sync $ do+        push "first"+        push "second"+    unlisten+    assertEqual "beh3" ["init", "second"] =<< readIORef outRef++-- | This demonstrates the fact that if there are multiple updates to a behaviour+-- in a given transaction, the last one prevails.+beh4 = TestCase $ do+    outRef <- newIORef []+    (push, unlisten) <- sync $ do+        (beh, push) <- newBehavior "init"+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])+        push "other"+        return (push, unlisten)+    sync $ do+        push "first"+        push "second"+    unlisten+    assertEqual "beh4" ["other", "second"] =<< readIORef outRef++beh5 = TestCase $ do+    (ea, push) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        beh <- hold "init" ea+        unlisten <- listen (map toUpper <$> values beh) $ \a -> modifyIORef outRef (++ [a])+        push "other"+        return unlisten+    sync $ do+        push "first"+        push "second"+    unlisten+    assertEqual "beh5" ["OTHER", "SECOND"] =<< readIORef outRef++behConstant = TestCase $ do+    outRef <- newIORef []+    unlisten <- sync $ listen (values $ pure 'X') $ \a -> modifyIORef outRef (++ [a])+    unlisten+    assertEqual "behConstant" ['X'] =<< readIORef outRef++valuesThenMap = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push (2 :: Int)+    sync $ push 7+    unlisten+    assertEqual "valuesThenMap" [109,102,107] =<< readIORef outRef ++-- | This is used for tests where values() produces a single initial value on listen,+-- and then we double that up by causing that single initial event to be repeated.+-- This needs testing separately, because the code must be done carefully to achieve+doubleUp :: Event a -> Event a+doubleUp e = merge e e++valuesTwiceThenMap = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (doubleUp . values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push (2 :: Int)+    sync $ push 7+    unlisten+    assertEqual "valuesThenMap" [109,109,102,102,107,107] =<< readIORef outRef +    +valuesThenCoalesce = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (coalesce (\_ x -> x) . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenCoalesce" [9,2,7] =<< readIORef outRef++valuesTwiceThenCoalesce = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (coalesce (+) . doubleUp. values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenCoalesce" [18,4,14] =<< readIORef outRef++valuesThenSnapshot = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bc, pushc) <- sync $ newBehavior 'a'+    outRef <- newIORef []+    unlisten <- sync $ listen (flip snapshot bc . values $ bi) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'b'+    sync $ pushi 2+    sync $ pushc 'c'+    sync $ pushi 7+    unlisten+    assertEqual "valuesThenSnapshot" ['a','b','c'] =<< readIORef outRef++valuesTwiceThenSnapshot = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bc, pushc) <- sync $ newBehavior 'a'+    outRef <- newIORef []+    unlisten <- sync $ listen (flip snapshot bc . doubleUp . values $ bi) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'b'+    sync $ pushi 2+    sync $ pushc 'c'+    sync $ pushi 7+    unlisten+    assertEqual "valuesThenSnapshot" ['a','a','b','b','c','c'] =<< readIORef outRef++valuesThenMerge = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bj, pushj) <- sync $ newBehavior (2 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (mergeWith (+) (values bi) (values bj)) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushi 1+    sync $ pushj 4+    unlisten+    assertEqual "valuesThenMerge" [11,1,4] =<< readIORef outRef ++valuesThenFilter = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (filterE (const True) . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenFilter" [9,2,7] =<< readIORef outRef++valuesTwiceThenFilter = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (filterE (const True) . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenFilter" [9,9,2,2,7,7] =<< readIORef outRef++valuesThenOnce = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (once . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenOnce" [9] =<< readIORef outRef++valuesTwiceThenOnce = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (once . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenOnce" [9] =<< readIORef outRef+    +-- | Test values being "executed" before listen. Somewhat redundant since this is+-- Haskell and "values b" is pure.+valuesLateListen = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    let bv = values b+    sync $ push 8+    unlisten <- sync $ listen bv $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    unlisten+    assertEqual "valuesLateListen" [8,2] =<< readIORef outRef++appl1 = TestCase $ do+    (ea, pusha) <- sync newEvent+    ba <- sync $ hold 0 ea+    (eb, pushb) <- sync newEvent+    bb <- sync $ hold 0 eb+    let esum = (+) <$> ba <*> bb+    outRef <- newIORef []+    unlisten <- sync $ listen (values esum) $ \sum -> modifyIORef outRef (++ [sum])+    sync $ pusha 5+    sync $ pushb 100+    sync $ pusha 10 >> pushb 200+    unlisten+    assertEqual "appl1" [0, 5, 105, 210] =<< readIORef outRef+    +snapshot1 = TestCase $ do+    (ea, pusha) <- sync newEvent+    (eb, pushb) <- sync newEvent+    bb <- sync $ hold 0 eb+    let ec = snapshotWith (,) ea bb+    outRef <- newIORef []+    unlisten <- sync $ listen ec $ \c -> modifyIORef outRef (++ [c])+    sync $ pusha 'A'+    sync $ pushb 50+    sync $ pusha 'B'+    sync $ pusha 'C' >> pushb 60+    sync $ pusha 'D'+    unlisten+    assertEqual "snapshot1" [('A',0),('B',50),('C',50),('D',60)] =<< readIORef outRef++holdIsDelayed = TestCase $ do+    (e, push) <- sync newEvent+    h <- sync $ hold (0 :: Int) e+    let pair = snapshotWith (\a b -> show a ++ " " ++ show b) e h+    outRef <- newIORef []+    unlisten <- sync $ listen pair $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 3+    unlisten+    assertEqual "holdIsDelayed" ["2 0", "3 2"] =<< readIORef outRef++count1 = TestCase $ do+    (ea, push) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        eCount <- countE ea+        listen eCount $ \c -> modifyIORef outRef (++ [c])+    sync $ push ()+    sync $ push ()+    sync $ push ()+    unlisten+    assertEqual "count1" [1,2,3] =<< readIORef outRef++collect1 = TestCase $ do+    (ea, push) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        ba <- hold 100 ea+        sum <- collect (\a s -> (a+s, a+s)) 0 ba+        listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])+    sync $ push 5+    sync $ push 7+    sync $ push 1+    sync $ push 2+    sync $ push 3+    unlisten+    assertEqual "collect1" [100, 105, 112, 113, 115, 118] =<< readIORef outRef++collect2 = TestCase $ do+    outRef <- newIORef []+    -- This is a bit of an edge case.+    (unlisten, push) <- sync $ do+        (ba, push) <- newBehavior 100+        sum <- collect (\a s -> (a + s, a + s)) 0 ba+        push 5+        unlisten <- listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])+        return (unlisten, push)+    sync $ push 7+    sync $ push 1+    unlisten+    assertEqual "collect2" [105, 112, 113] =<< readIORef outRef++collectE1 = TestCase $ do+    (ea, push) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        sum <- collectE (\a s -> (a+s, a+s)) 100 ea+        listen sum $ \sum -> modifyIORef outRef (++ [sum])+    sync $ push 5+    sync $ push 7+    sync $ push 1+    sync $ push 2+    sync $ push 3+    unlisten+    assertEqual "collectE1" [105, 112, 113, 115, 118] =<< readIORef outRef++collectE2 = TestCase $ do+    (ea, push) <- sync newEvent+    outRef <- newIORef []+    -- This behaviour is a little bit odd but difficult to fix in the+    -- implementation. However, it shouldn't be too much of a problem in+    -- practice. Here we are defining it.+    unlisten <- sync $ do+        sum <- collectE (\a s -> (a + s, a + s)) 100 ea+        push 5+        listen sum $ \sum -> modifyIORef outRef (++ [sum])+    sync $ push 7+    sync $ push 1+    unlisten+    assertEqual "collectE2" [105, 112, 113] =<< readIORef outRef++switchE1 = TestCase $ do+    (ea, pusha) <- sync newEvent+    (eb, pushb) <- sync newEvent+    (esw, pushsw) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        sw <- hold ea esw+        let eo = switchE sw+        unlisten <- listen eo $ \o -> modifyIORef outRef (++ [o])+        pusha 'A'+        pushb 'a'+        return unlisten+    sync $ pusha 'B' >> pushb 'b'+    sync $ pushsw eb >> pusha 'C' >> pushb 'c'+    sync $ pusha 'D' >> pushb 'd'+    sync $ pusha 'E' >> pushb 'e' >> pushsw ea+    sync $ pusha 'F' >> pushb 'f'+    sync $ pusha 'G' >> pushb 'g' >> pushsw eb+    sync $ pusha 'H' >> pushb 'h' >> pushsw ea+    sync $ pusha 'I' >> pushb 'i' >> pushsw ea+    unlisten+    assertEqual "switchE1" "ABCdeFGhI" =<< readIORef outRef++switch1 = TestCase $ do+    outRef <- newIORef []+    (ba, bb, pusha, pushb, pushsw, unlisten) <- sync $ do+        (ba, pusha) <- newBehavior 'A'+        (bb, pushb) <- newBehavior 'a'+        (bsw, pushsw) <- newBehavior ba+        bo <- switch bsw+        unlisten <- listen (values bo) $ \o -> modifyIORef outRef (++ [o])+        return (ba, bb, pusha, pushb, pushsw, unlisten)+    sync $ pusha 'B' >> pushb 'b'+    sync $ pushsw bb >> pusha 'C' >> pushb 'c'+    sync $ pusha 'D' >> pushb 'd'+    sync $ pusha 'E' >> pushb 'e' >> pushsw ba+    sync $ pusha 'F' >> pushb 'f'+    sync $ pushsw bb+    sync $ pushsw ba+    sync $ pusha 'G' >> pushb 'g' >> pushsw bb+    sync $ pusha 'H' >> pushb 'h' >> pushsw ba+    sync $ pusha 'I' >> pushb 'i' >> pushsw ba+    unlisten+    assertEqual "switch1" "ABcdEFfFgHI" =<< readIORef outRef+    +once1 = TestCase $ do+    (ea, pusha) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        listen (once ea) $ \a -> modifyIORef outRef (++ [a])+    sync $ pusha 'A'+    sync $ pusha 'B'+    sync $ pusha 'C'+    unlisten+    assertEqual "switch1" "A" =<< readIORef outRef++once2 = TestCase $ do+    (ea, pusha) <- sync newEvent+    outRef <- newIORef []+    unlisten <- sync $ do+        pusha 'A'+        listen (once ea) $ \a -> modifyIORef outRef (++ [a])+    sync $ pusha 'B'+    sync $ pusha 'C'+    unlisten+    assertEqual "switch1" "A" =<< readIORef outRef++data Page = Page { unPage :: Reactive (Char, Event Page) }++cycle1 = TestCase $ do+    outRef <- newIORef []+    (ep, push) <- sync newEvent+    bo <- sync $ do+        let initPair = ('a', ep)+        rec+            bPair <- hold initPair ePage+            let ePage = execute $ unPage <$> switchE (snd <$> bPair)+        return (fst <$> bPair)+    unlisten <- sync $ listen (values bo) $ \o -> modifyIORef outRef (++ [o])+    sync $ push (Page $ return ('b', ep))+    sync $ push (Page $ return ('c', ep))+    unlisten+    assertEqual "cycle1" "abc" =<< readIORef outRef++mergeWith1 = TestCase $ do+    outRef <- newIORef []+    (ea, pushA) <- sync newEvent+    (eb, pushB) <- sync newEvent+    unlisten <- sync $ do+        pushA 5+        listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])+    sync $ pushA 2+    sync $ pushB 3+    sync $ pushA 10 >> pushB 4+    sync $ pushB 7 >> pushA 1+    unlisten+    assertEqual "mergeWith1" [5,2,3,14,8] =<< readIORef outRef++mergeWith2 = TestCase $ do+    outRef <- newIORef []+    (ea, pushA) <- sync newEvent+    (eb, pushB) <- sync newEvent+    unlisten <- sync $ do+        pushA 5+        unlisten <- listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])+        pushB 99+        return unlisten+    unlisten+    assertEqual "mergeWith2" [104] =<< readIORef outRef++mergeWith3 = TestCase $ do+    outRef <- newIORef []+    (ea, pushA) <- sync newEvent+    (eb, pushB) <- sync newEvent+    unlisten <- sync $ do+        listen (mergeWith (+) ea eb) $ \o -> modifyIORef outRef (++ [o])+    sync $ pushA 2+    sync $ pushB 3 >> pushB 1 >> pushA 10+    sync $ pushB 9 >> pushB 11 >> pushB 12+    sync $ pushA 32 >> pushA 11 >> pushA 12+    unlisten+    assertEqual "mergeWith3" [2,14,32,55] =<< readIORef outRef++coalesce1 = TestCase $ do+    outRef <- newIORef []+    (ea, pushA) <- sync newEvent+    (eb, pushB) <- sync newEvent+    unlisten <- sync $ do+        listen (coalesce (+) (merge ea eb)) $ \o -> modifyIORef outRef (++ [o])+    sync $ pushA 2+    sync $ pushA 5 >> pushB 6+    unlisten+    assertEqual "coalesce1" [2, 11] =<< readIORef outRef++tests = test [ event1, fmap1, merge1, filterJust1, filterE1, gate1, beh1, beh2, beh3, beh4, beh5,+    behConstant, valuesThenMap, valuesTwiceThenMap, valuesThenCoalesce, valuesTwiceThenCoalesce,+    valuesThenSnapshot, valuesTwiceThenSnapshot, valuesThenMerge, valuesThenFilter,+    valuesTwiceThenFilter, valuesThenOnce, valuesTwiceThenOnce, valuesLateListen,+    holdIsDelayed, appl1, snapshot1, count1, collect1, collect2, collectE1, collectE2, switchE1,+    switch1, once1, once2, cycle1{-, mergeWith1, mergeWith2, mergeWith3,+    coalesce1-} ]++main = {-forever $-} runTestTT tests+

@@ -1,10 +1,10 @@ name:                sodium-version:             0.5.0.1+version:             0.5.0.2 synopsis:            Sodium Reactive Programming (FRP) System description:            A general purpose Reactive Programming (FRP) system. This is part of a project to   implement reactive libraries with similar interfaces across a range of programming-  languages.+  languages at <http://reactiveprogramming.org/>   .    * Goals include simplicity and completeness.   .@@ -24,7 +24,8 @@            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.1 Internal improvements;+           0.5.0.2 Fix multiple memory leaks license:             BSD3 license-file:        LICENSE author:              Stephen Blackheath@@ -33,7 +34,14 @@ category:            FRP build-type:          Simple cabal-version:       >=1.8-extra-source-files:  examples/tests.hs+extra-source-files:  examples/tests/README.txt+                     examples/tests/unit-tests.hs+                     examples/tests/memory-test-1.hs+                     examples/tests/memory-test-2.hs+                     examples/tests/memory-test-3.hs+                     examples/tests/memory-test-4.hs+                     examples/tests/memory-test-5.hs+                     examples/tests/memory-test-6.hs                      examples/games/poodle.hs                      examples/games/freecell.hs                      examples/games/Engine.hs@@ -118,6 +126,6 @@   hs-source-dirs:      src   exposed-modules:     FRP.Sodium, FRP.Sodium.Internal, FRP.Sodium.Context   other-modules:       FRP.Sodium.Plain-  build-depends:       base >= 4.3.0.0 && < 4.6.0.0,-                       containers >= 0.4.0.0 && < 0.5.0.0,+  build-depends:       base >= 4.3.0.0 && < 4.7.0.0,+                       containers >= 0.4.0.0 && < 0.6.0.0,                        mtl >= 2.0.0.0 && < 2.2.0.0

@@ -17,7 +17,7 @@ -- --   * Applicative 'pure' is used to give a constant 'Behavior'. -----   * Recursive do (via DoRec) to make state loops with the @rec@ keyword.+--   * Recursive do (using the DoRec language extension) to make state loops with the @rec@ keyword. -- -- Here's an example of recursive do to write state-keeping loops. Note that -- all 'hold's are delayed, so 'attachWith' will capture the /old/ value of the state /s/.@@ -37,6 +37,7 @@         sync,         newEvent,         newBehavior,+        newBehaviour,         listen,         -- * FRP core language         Event,

@@ -83,6 +83,11 @@     -- | Throw away all event occurrences except for the first one.     once          :: Context r => Event r a -> Event r a +-- | A time-varying value, British spelling.+type Behaviour r a = Behavior r a++-- | Create a new 'Behavior' along with an action to push changes into it.+-- American spelling. newBehavior :: forall r a . Context r =>                a  -- ^ Initial behavior value             -> Reactive r (Behavior r a, a -> Reactive r ())@@ -90,6 +95,13 @@     (ev, push) <- newEvent     beh <- hold initA ev     return (beh, push)++-- | Create a new 'Behavior' along with an action to push changes into it.+-- British spelling.+newBehaviour :: forall r a . Context r =>+               a  -- ^ Initial behavior value+            -> Reactive r (Behavior r a, a -> Reactive r ())+newBehaviour = newBehavior  -- | Merge two streams of events of the same type, combining simultaneous -- event occurrences.

@@ -13,11 +13,15 @@         Node,         newEventLinked,         newEvent,+        newEventImpl,         finalizeEvent,         finalizeListen,         ioReactive,         Unlistener,-        addCleanup,+        addCleanup_Listen,+        Sample(..),+        unSample,+        addCleanup_Sample,         unlistenize     ) where 

@@ -10,9 +10,9 @@ -- -fno-cse just in case, since we're using unsafePerformIO.  import Control.Applicative-import Control.Concurrent import Control.Concurrent.Chan-import Control.Concurrent.MVar+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, newMVar, readMVar)+import qualified Control.Concurrent.MVar as MV import Control.Exception (evaluate) import Control.Monad import Control.Monad.State.Strict@@ -30,6 +30,23 @@ import System.Mem.Weak import System.IO.Unsafe +modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b+modifyMVar mv f = MV.modifyMVar mv $ \a -> do+    (a', b') <- f a+    evaluate a'+    return (a', b')++modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVar_ mv f = MV.modifyMVar_ mv $ \a -> do+    a' <- f a+    evaluate a'+    return a'++putMVar :: MVar a -> a -> IO ()+putMVar mv a = do+    evaluate a+    MV.putMVar mv a+ -- | Phantom type for use with 'R.Context' type class. data Plain @@ -58,9 +75,20 @@ -- | A time-varying value, British spelling. 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'+ instance R.Context Plain where -    data Reactive Plain a = Reactive (StateT ReactiveState IO a)+    newtype Reactive Plain a = Reactive (StateT ReactiveState IO a)      data Event Plain a = Event {  -- Must be data not newtype, because we need to attach finalizers to it             -- | Listen for event occurrences on this event, to be handled by the specified@@ -73,7 +101,7 @@             -- | Internal: Extract the underlyingEvent event for this behavior.             underlyingEvent :: Event a,             -- | Obtain the current value of a behavior.-            behSample       :: Reactive a+            behSample       :: Sample a         }     sync = sync     ioReactive = ioReactive@@ -170,9 +198,11 @@         l1 <- getListen ea         l2 <- getListen eb                                         (l, push, nodeRef) <- ioReactive newEventImpl-        unlistener1 <- unlistenize $ runListen l1 (Just nodeRef) False push-        unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) False push-        (addCleanup unlistener1 <=< addCleanup unlistener2) l+        unlistener <- unlistenize $ do+            u1 <- runListen l1 (Just nodeRef) False push+            u2 <- runListen l2 (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@@ -185,7 +215,7 @@         unlistener <- unlistenize $ runListen l (Just nodeRef) False $ \ma -> case ma of             Just a -> push a             Nothing -> return ()-        addCleanup 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@@ -194,22 +224,18 @@ -- the transaction. hold          :: a -> Event a -> Reactive (Behavior a) hold initA ea = do-    bsRef <- ioReactive $ newIORef (BehaviorState initA Nothing)-    unlistener <- unlistenize $ {-lastFiringOnly-} (linkedListen ea) Nothing False $ \a -> do+    bsRef <- ioReactive $ newIORef $ initA `seq` BehaviorState initA Nothing+    unlistener <- unlistenize $ linkedListen ea Nothing False $ \a -> do         bs <- ioReactive $ readIORef bsRef-        ioReactive $ writeIORef bsRef $ bs { bsUpdate = Just a }+        ioReactive $ writeIORef bsRef $ a `seq` bs { bsUpdate = Just a }         when (isNothing (bsUpdate bs)) $ scheduleLast $ ioReactive $ do             bs <- readIORef bsRef             let newCurrent = fromJust (bsUpdate bs)-                bs' = newCurrent `seq` BehaviorState newCurrent Nothing-            evaluate bs'-            writeIORef bsRef bs'-    let gl = do-            l <- getListen ea-            addCleanup unlistener l-        beh = Behavior {-                underlyingEvent = Event gl (evCacheRef ea),-                behSample = ioReactive $ bsCurrent <$> readIORef bsRef+            writeIORef bsRef $ newCurrent `seq` BehaviorState newCurrent Nothing+    sample <- ioReactive $ addCleanup_Sample unlistener (Sample $ return $ bsCurrent <$> readIORef bsRef)+    let beh = sample `seq` Behavior {+                underlyingEvent = ea,+                behSample = sample             }     return beh @@ -233,10 +259,15 @@     cacheRef = unsafePerformIO $ newIORef Nothing     gl = do         (l, push, nodeRef) <- ioReactive newEventImpl-        unlistener <- unlistenize $ linkedListen ea (Just nodeRef) False $ \a -> do-            b <- sample bb-            push (f a b)-        addCleanup unlistener l+        sample' <- ioReactive $ unSample_ $ behSample $ bb+        _ <- ioReactive $ touch sample'+        unlistener <- unlistenize $ do+            unlisten <- 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@@ -256,7 +287,7 @@                 ioReactive doUnlisten2                 (ioReactive . writeIORef unlisten2Ref) =<< (Just <$> linkedListen ea (Just nodeRef) True push)             return $ unlisten1 >> doUnlisten2-        addCleanup unlistener1 l+        addCleanup_Listen unlistener1 l  -- | Unwrap a behavior inside another behavior to give a time-varying behavior implementation. switch        :: Behavior (Behavior a) -> Reactive (Behavior a)@@ -280,14 +311,13 @@     cacheRef = unsafePerformIO $ newIORef Nothing     gl = do         (l', push, nodeRef) <- ioReactive newEventImpl-        unlistener <- unlistenize $ do-            l <- getListen ev-            runListen l (Just nodeRef) False $ \action -> action >>= push-        addCleanup unlistener l'+        l <- getListen ev+        unlistener <- unlistenize $ runListen l (Just nodeRef) False $ \action -> action >>= push+        addCleanup_Listen unlistener l'  -- | Obtain the current value of a behavior. sample        :: Behavior a -> Reactive a-sample = behSample+sample b = ioReactive . unSample . behSample $ b  -- | If there's more than one firing in a single transaction, combine them into -- one using the specified combining function.@@ -313,7 +343,7 @@                 Just out <- ioReactive $ readIORef outRef                 ioReactive $ writeIORef outRef Nothing                 push out-        addCleanup unlistener l+        addCleanup_Listen unlistener l  -- | Throw away all event occurrences except for the first one. once :: Event a -> Event a@@ -333,12 +363,20 @@                         scheduleLast $ ioReactive unlisten                         push a             return unlisten-        addCleanup unlistener l+        addCleanup_Listen unlistener l +-- | Create a new 'Behavior' along with an action to push changes into it.+-- American spelling. newBehavior :: a  -- ^ Initial behavior value             -> Reactive (Behavior a, a -> Reactive ()) newBehavior = R.newBehavior +-- | Create a new 'Behavior' along with an action to push changes into it.+-- British spelling.+newBehaviour :: a  -- ^ Initial behavior value+            -> Reactive (Behavior a, a -> Reactive ())+newBehaviour = R.newBehaviour+ -- | Merge two streams of events of the same type, combining simultaneous -- event occurrences. --@@ -444,13 +482,13 @@  type ID = Int64 -instance PriorityQueueable (Maybe (IORef Node)) where-    priorityOf (Just nodeRef) = noRank <$> readIORef nodeRef+instance PriorityQueueable (Maybe (MVar Node)) where+    priorityOf (Just nodeRef) = noRank <$> readMVar nodeRef     priorityOf Nothing        = return maxBound  data ReactiveState = ReactiveState {         asQueue1     :: Seq (Reactive ()),-        asQueue2     :: PriorityQueue (Maybe (IORef Node)) (Reactive ()),+        asQueue2     :: PriorityQueue (Maybe (MVar Node)) (Reactive ()),         asFinal      :: Seq (Reactive ())     } @@ -490,14 +528,15 @@ scheduleLast :: Reactive () -> Reactive () scheduleLast task = Reactive $ modify $ \as -> as { asFinal = asFinal as |> task } -data Listen a = Listen { runListen_ :: Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) }+data Listen a = Listen { runListen_ :: Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) } -runListen :: Listen a -> Maybe (IORef 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-    o <- runListen_ l mv suppressEarlierFirings handle-    _ <- ioReactive $ evaluate l-    return o+    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)@@ -512,7 +551,7 @@  -- | 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 (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())+linkedListen :: Event a -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) linkedListen ev mMvTarget suppressEarlierFirings handle = do     l <- getListen ev     runListen l mMvTarget suppressEarlierFirings handle@@ -531,70 +570,76 @@ data Node = Node {         noID        :: NodeID,         noRank      :: Int64,-        noListeners :: Map ID (IORef Node)+        noListeners :: Map ID (MVar Node)     } -newNode :: IO (IORef Node)+newNode :: IO (MVar Node) newNode = do     nodeID <- readIORef (paNextNodeID partition)     modifyIORef (paNextNodeID partition) succ-    newIORef (Node nodeID 0 M.empty)+    newMVar (Node nodeID 0 M.empty) -wrap :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> IO (Listen a)+wrap :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> IO (Listen a) {-# NOINLINE wrap #-} wrap l = return (Listen l) -touch :: Listen a -> IO ()+touch :: a -> IO () {-# NOINLINE touch #-}-touch l = evaluate l >> return ()+touch a = evaluate a >> return () -linkNode :: IORef Node -> ID -> IORef Node -> IO Bool+linkNode :: MVar Node -> ID -> MVar Node -> IO Bool linkNode nodeRef iD mvTarget = do-    no <- readIORef nodeRef+    no <- readMVar nodeRef     modified <- ensureBiggerThan S.empty mvTarget (noRank no)-    modifyIORef nodeRef $ \no ->-        no { noListeners = M.insert iD mvTarget (noListeners no) }+    modifyMVar_ nodeRef $ \no -> return $+        let listeners' = M.insert iD mvTarget (noListeners no)+        in  listeners' `seq` no { noListeners = listeners' }     return modified -ensureBiggerThan :: Set NodeID -> IORef Node -> Int64 -> IO Bool+ensureBiggerThan :: Set NodeID -> MVar Node -> Int64 -> IO Bool ensureBiggerThan visited nodeRef limit = do-    no <- readIORef nodeRef-    if noRank no > limit || noID no `S.member` visited then+    no <- takeMVar nodeRef+    if noRank no > limit || noID no `S.member` visited then do+            putMVar nodeRef no             return False         else do             let newSerial = succ limit             --putStrLn $ show (noRank no) ++ " -> " ++ show newSerial-            modifyIORef nodeRef $ \no -> no { noRank = newSerial }+            putMVar nodeRef $ newSerial `seq` no { noRank = newSerial }             forM_ (M.elems . noListeners $ no) $ \mvTarget -> do                 ensureBiggerThan (S.insert (noID no) visited) mvTarget newSerial             return True -unlinkNode :: IORef Node -> ID -> IO ()+unlinkNode :: MVar Node -> ID -> IO () unlinkNode nodeRef iD = do-    modifyIORef nodeRef $ \no ->-        no { noListeners = M.delete iD (noListeners no) }+    modifyMVar_ nodeRef $ \no -> do+        let listeners' = M.delete iD (noListeners no)+        return $ listeners' `seq` no { noListeners = listeners' }  -- | 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 (), IORef Node)+newEventImpl :: forall p a . IO (Listen a, a -> Reactive (), MVar Node) newEventImpl = do     nodeRef <- newNode     mvObs <- newMVar (Observer 0 M.empty [])     cacheRef <- newIORef Nothing     rec         let l mMvTarget suppressEarlierFirings handle = do-                (firings, unlisten, iD) <- ioReactive $ modifyMVar mvObs $ \ob -> return $+                (firings, unlisten, iD) <- ioReactive $ modifyMVar mvObs $ \ob -> do                     let iD = obNextID ob-                        handle' a = handle a >> ioReactive (touch listen)-                        ob' = ob { obNextID    = succ iD,-                                   obListeners = M.insert iD handle' (obListeners ob) }+                        nextID' = succ iD+                        listeners' = M.insert iD handle (obListeners ob)+                        ob' = nextID' `seq` listeners' `seq` +                              ob { obNextID    = nextID',+                                   obListeners = listeners' }                         unlisten = do-                            modifyMVar_ mvObs $ \ob -> return $ ob {-                                    obListeners = M.delete iD (obListeners ob)-                                }+                            modifyMVar_ mvObs $ \ob -> do+                                let listeners' = M.delete iD (obListeners ob)+                                return $ listeners' `seq` ob { obListeners = listeners' }                             unlinkNode nodeRef iD+                            touch listen                             return ()-                    in (ob', (reverse . obFirings $ ob, unlisten, iD))+                    return (ob', (reverse . obFirings $ ob, unlisten, iD))                 modified <- case mMvTarget of                     Just mvTarget -> ioReactive $ linkNode nodeRef iD mvTarget                     Nothing       -> return False@@ -605,17 +650,17 @@                 return unlisten         listen <- wrap l  -- defeat optimizer on ghc-7.0.4     let push a = do+            ioReactive $ evaluate a             ob <- ioReactive $ modifyMVar mvObs $ \ob -> return $                 (ob { obFirings = a : obFirings ob }, ob)             -- If this is the first firing...             when (null (obFirings ob)) $ scheduleLast $ ioReactive $ do                 modifyMVar_ mvObs $ \ob -> return $ ob { obFirings = [] }-            ioReactive $ evaluate a             mapM_ ($ a) (M.elems . obListeners $ ob)     return (listen, push, nodeRef)  -- | Returns an event, and a push action for pushing a value into the event.-newEventLinked :: IO (Event a, a -> Reactive (), IORef Node)+newEventLinked :: IO (Event a, a -> Reactive (), MVar Node) newEventLinked = do     (listen, push, nodeRef) <- newEventImpl     cacheRef <- newIORef Nothing@@ -626,22 +671,23 @@     return (ev, push, nodeRef)  instance Functor (R.Event Plain) where-    f `fmap` Event getListen cacheRef = Event getListen' cacheRef+    f `fmap` e = Event getListen' cacheRef       where         cacheRef = unsafePerformIO $ newIORef Nothing         getListen' = do             return $ Listen $ \mNodeRef suppressEarlierFirings handle -> do-                l <- getListen+                l <- getListen e                 runListen l mNodeRef suppressEarlierFirings (handle . f)  instance Functor (R.Behavior Plain) where     f `fmap` Behavior underlyingEvent sample =-        Behavior (f `fmap` underlyingEvent) (f `fmap` sample)+        sample' `seq` Behavior (f `fmap` underlyingEvent) sample'+        where sample' = Sample $ return $ f `fmap` unSample sample  constant :: a -> Behavior a constant a = Behavior {         underlyingEvent = never,-        behSample = return a+        behSample = Sample $ return $ return a     }  data BehaviorState a = BehaviorState {@@ -665,13 +711,22 @@     addFinalizer l unlisten     return l +-- | Add a finalizer to a Reactive.+finalizeSample :: Sample a -> IO () -> IO (Sample a)+{-# NOINLINE finalizeSample #-}+finalizeSample s unlisten = do+    addFinalizer s unlisten+    return s+ 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'.+-- attached to an output event using 'addCleanup_Listen'. unlistenize :: Reactive (IO ()) -> Reactive Unlistener unlistenize 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.     scheduleEarly $ do         mOldUnlisten <- ioReactive $ takeMVar ref         case mOldUnlisten of@@ -686,24 +741,30 @@  -- | Cause the things listened to with unlistenize to be unlistened when the -- specified listener is not referenced any more.-addCleanup :: Unlistener -> Listen a -> Reactive (Listen a)-addCleanup (Unlistener ref) l = ioReactive $ finalizeListen l $ do+addCleanup_Listen :: Unlistener -> Listen a -> Reactive (Listen a)+addCleanup_Listen (Unlistener ref) l = ioReactive $ finalizeListen l $ do     mUnlisten <- takeMVar ref     fromMaybe (return ()) mUnlisten     putMVar ref Nothing +addCleanup_Sample :: Unlistener -> Sample a -> IO (Sample a)+addCleanup_Sample (Unlistener ref) r = finalizeSample r $ do+    mUnlisten <- takeMVar ref+    fromMaybe (return ()) mUnlisten+    putMVar ref Nothing+ -- | Listen to the value of this behavior with an initial callback giving -- the current value. Can get multiple values per transaction, the last of -- which is considered valid. You would normally want to use 'listenValue', -- which removes the extra unwanted values.-listenValueRaw :: Behavior a -> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())+listenValueRaw :: Behavior a -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) listenValueRaw ba = lastFiringOnly $ \mNodeRef suppressEarlierFirings handle -> do     a <- sample ba     handle a     linkedListen (underlyingEvent ba) mNodeRef suppressEarlierFirings handle  -- | Queue the specified atomic to run at the end of the priority 2 queue-schedulePrioritized :: Maybe (IORef Node)+schedulePrioritized :: Maybe (MVar Node)                     -> Reactive ()                     -> Reactive () schedulePrioritized mNodeRef task = Reactive $ do@@ -717,8 +778,8 @@  -- Clean up the listener so it gives only one value per transaction, specifically -- the last one.                -lastFiringOnly :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()))-     -> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())+lastFiringOnly :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()))+                -> Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) lastFiringOnly listen mNodeRef suppressEarlierFirings handle = do     aRef <- ioReactive $ newIORef Nothing     listen mNodeRef suppressEarlierFirings $ \a -> do@@ -734,14 +795,14 @@ listenValueTrans :: Behavior a -> (a -> Reactive ()) -> Reactive (IO ()) listenValueTrans ba = listenValueRaw ba Nothing False -eventify :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Event a+eventify :: (Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Event a eventify listen = Event gl cacheRef   where     cacheRef = unsafePerformIO $ newIORef Nothing     gl = do         (l, push, nodeRef) <- ioReactive newEventImpl         unlistener <- unlistenize $ listen (Just nodeRef) False push-        addCleanup unlistener l+        addCleanup_Listen unlistener l  instance Applicative (R.Behavior Plain) where     pure = constant@@ -750,21 +811,23 @@         cacheRef = unsafePerformIO $ newIORef Nothing         u = Event gl cacheRef         gl = do-            fRef <- ioReactive . newIORef =<< s1-            aRef <- ioReactive . newIORef =<< s2+            fRef <- ioReactive $ newIORef =<< unSample s1+            aRef <- ioReactive $ newIORef =<< unSample s2             l1 <- getListen u1             l2 <- getListen u2             (l, push, nodeRef) <- ioReactive newEventImpl-            unlistener1 <- unlistenize $ runListen l1 (Just nodeRef) False $ \f -> do-                ioReactive $ writeIORef fRef f-                a <- ioReactive $ readIORef aRef-                push (f a)-            unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) False $ \a -> do-                f <- ioReactive $ readIORef fRef-                ioReactive $ writeIORef aRef a-                push (f a)-            (addCleanup unlistener1 <=< addCleanup unlistener2) l-        s = ($) <$> s1 <*> s2+            unlistener <- unlistenize $ do+                un1 <- runListen l1 (Just nodeRef) False $ \f -> do+                    ioReactive $ writeIORef fRef f+                    a <- ioReactive $ readIORef aRef+                    push (f a)+                un2 <- runListen l2 (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  {- -- | Cross the specified event over to a different partition.