git.iko.soy/reflex
on develop help sign in
Merge branch 'release-0.2'
commit48e84eecd61071c233a4e79c212fa87f91543506 authorRyan Trinkle <ryan.trinkle@gmail.com> dateTue 5 May 2015, 17:41 (11 years ago) parent2653f40c108ea4
10 files changed+384−118
compare with develop
unifiedsplit
README.md+15 bench/Main.hs+110 default.nix+2−2 reflex.cabal+22−5 src/Control/Monad/Ref.hs−85 src/Reflex/Class.hs+68−5 src/Reflex/Dynamic.hs+83−2 src/Reflex/Dynamic/TH.hs+1−1 src/Reflex/Host/Class.hs+7 src/Reflex/Spider/Internal.hs+76−18
README.mdnew file+15
@@ -0,0 +1,15 @@
1+## Reflex
2+### Practical Functional Reactive Programming
3+
4+Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.
5+
6+[Reflex-DOM](https://github.com/ryantrinkle/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps.
7+
8+Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/ryantrinkle/try-reflex and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c).
9+
10+### Additional resources
11+[try reflex](https://github.com/ryantrinkle/try-reflex)
12+
13+[reddit/r/reflexfrp](http://www.reddit.com/r/reflexfrp)
14+
15+irc.freenode.net #reflex-frp
bench/Main.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TypeFamilies #-}
5+module Main where
6+
7+import Data.Functor.Misc
8+import Control.Monad.Primitive
9+import Control.Monad.IO.Class
10+import Data.Dependent.Sum
11+import Control.Concurrent.STM
12+import Control.Applicative
13+import System.IO.Unsafe
14+import Data.IORef
15+import Control.DeepSeq
16+import Control.Exception (evaluate)
17+import Control.Monad
18+import Reflex
19+import Reflex.Host.Class
20+import System.Mem
21+import System.IO
22+import Criterion.Main
23+
24+import qualified Data.Traversable as T
25+
26+import qualified Data.Dependent.Map as DM
27+
28+
29+main :: IO ()
30+main = defaultMain
31+ [ bgroup "micro" micros ]
32+
33+instance NFData (IORef a) where
34+ rnf x = seq x ()
35+
36+instance NFData (TVar a) where
37+ rnf x = seq x ()
38+
39+newtype WHNF a = WHNF a
40+instance NFData (WHNF a) where
41+ rnf (WHNF a) = seq a ()
42+
43+withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
44+withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
45+ bench name . nfIO $ runSpiderHost (action a)
46+
47+withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
48+withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
49+ bench name . whnfIO $ runSpiderHost (action a)
50+
51+
52+micros :: [Benchmark]
53+micros =
54+ [ bench "newIORef" $ whnfIO $ void $ newIORef ()
55+ , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)
56+ , bench "newTVar" $ whnfIO $ void $ newTVarIO ()
57+ , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)
58+ , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $
59+ \trigger -> return () <$ evaluate trigger
60+ , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef
61+ , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst
62+ , withSetupWHNF "subscribeSwitch"
63+ (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)
64+ (subscribeEvent . switch)
65+ , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev
66+ , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)
67+ , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)
68+ , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()
69+ , withSetupWHNF "fireEventsAndRead(single/single)"
70+ (newEventWithTriggerRef >>= subscribePair)
71+ (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
72+ , withSetupWHNF "fireEventsOnly"
73+ (newEventWithTriggerRef >>= subscribePair)
74+ (\(subd, trigger) -> do
75+ Just key <- liftIO $ readIORef trigger
76+ fireEvents [key :=> (42 :: Int)])
77+ , withSetupWHNF "fireEventsAndRead(head/merge1)"
78+ (setupMerge 1 >>= subscribePair)
79+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
80+ , withSetupWHNF "fireEventsAndRead(head/merge100)"
81+ (setupMerge 100 >>= subscribePair)
82+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
83+ , withSetupWHNF "fireEventsAndRead(head/merge10000)"
84+ (setupMerge 10000 >>= subscribePair)
85+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
86+ , withSetupWHNF "fireEventsOnly(head/merge100)"
87+ (setupMerge 100 >>= subscribePair)
88+ (\(subd, t:riggers) -> do
89+ Just key <- liftIO $ readIORef t
90+ fireEvents [key :=> (42 :: Int)])
91+ , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev
92+ , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
93+ ]
94+
95+setupMerge :: Int
96+ -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),
97+ [IORef (Maybe (EventTrigger Spider a))])
98+setupMerge num = do
99+ (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef
100+ let !m = DM.fromList [WrapArg (Const2 i) :=> v | (i,v) <- zip [0..] evs]
101+ pure (merge m, triggers)
102+
103+subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)
104+subscribePair (ev, b) = (,b) <$> subscribeEvent ev
105+
106+fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b
107+ -> SpiderHost (Maybe b)
108+fireAndRead trigger val subd = do
109+ Just key <- liftIO $ readIORef trigger
110+ fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence
default.nix+2−2
@@ -1,12 +1,12 @@
11{ mkDerivation, dependent-map, dependent-sum
2−, mtl, semigroups, these
2+, mtl, ref-tf, semigroups, these
33}:
44mkDerivation {
55 pname = "reflex";
66 version = "0.1";
77 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
88 buildDepends = [
9− dependent-map dependent-sum mtl semigroups these
9+ dependent-map dependent-sum mtl ref-tf semigroups these
1010 ];
1111 license = null;
1212}
reflex.cabal+22−5
@@ -1,5 +1,5 @@
11Name: reflex
2−Version: 0.1.1
2+Version: 0.2
33Synopsis: Higher-order Functional Reactive Programming
44Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
55License: BSD3
@@ -20,11 +20,12 @@ library
2020 dependent-sum == 0.2.*,
2121 dependent-map == 0.1.*,
2222 semigroups == 0.16.*,
23− mtl == 2.2.*,
23+ mtl >= 2.1 && < 2.3,
2424 containers == 0.5.*,
2525 these == 0.4.*,
2626 primitive == 0.5.*,
27− template-haskell >= 2.9 && < 2.11
27+ template-haskell >= 2.9 && < 2.11,
28+ ref-tf == 0.4.*
2829
2930 exposed-modules:
3031 Reflex,
@@ -34,13 +35,29 @@ library
3435 Reflex.Dynamic,
3536 Reflex.Dynamic.TH,
3637 Reflex.Host.Class,
37− Data.Functor.Misc,
38− Control.Monad.Ref
38+ Data.Functor.Misc
3939
4040 other-extensions: TemplateHaskell
4141 ghc-prof-options: -fprof-auto
4242 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4343
44+benchmark spider-bench
45+ type: exitcode-stdio-1.0
46+ hs-source-dirs: bench
47+ main-is: Main.hs
48+ ghc-options: -O2 -rtsopts
49+ build-depends:
50+ base,
51+ dependent-sum,
52+ dependent-map,
53+ transformers >= 0.3 && < 0.5,
54+ stm == 2.4.*,
55+ deepseq >= 1.3 && < 1.5,
56+ mtl,
57+ primitive,
58+ criterion == 1.1.*,
59+ reflex
60+
4461source-repository head
4562 type: git
4663 location: https://github.com/ryantrinkle/reflex
src/Control/Monad/Ref.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-# LANGUAGE RecursiveDo, TypeFamilies, LambdaCase #-}
2−module Control.Monad.Ref where
3−
4−import Control.Monad
5−import Control.Monad.Trans
6−import Control.Monad.Reader
7−import Control.Monad.Writer
8−import Data.IORef
9−
10−class Monad m => MonadRef m where
11− type Ref m :: * -> *
12− newRef :: a -> m (Ref m a)
13− readRef :: Ref m a -> m a
14− writeRef :: Ref m a -> a -> m ()
15− atomicModifyRef :: Ref m a -> (a -> (a, b)) -> m b
16−
17−instance MonadRef IO where
18− type Ref IO = IORef
19− {-# INLINE newRef #-}
20− newRef = newIORef
21− {-# INLINE readRef #-}
22− readRef = readIORef
23− {-# INLINE writeRef #-}
24− writeRef = writeIORef
25− {-# INLINE atomicModifyRef #-}
26− atomicModifyRef r f = do
27− result <- atomicModifyIORef' r f
28−-- evaluate =<< readIORef r --TODO: Verify that ghcjs now strictly evaluates the values in atomicModifyIORef', then remove this line
29− return result
30−
31−{-# INLINE cacheM #-}
32−cacheM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m ())
33−cacheM a = do
34− r <- newRef undefined
35− let invalidate = writeRef r $ do
36− result <- a
37− writeRef r $ return result
38− return result
39− invalidate
40− return (join $ readRef r, invalidate)
41−
42−{-# INLINE cacheMWithTry #-}
43−cacheMWithTry :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m (Maybe a), m ())
44−cacheMWithTry a = do
45− r <- newRef $ Left a
46− let invalidate = writeRef r $ Left a
47− get = readRef r >>= \case
48− Left a' -> do
49− result <- a'
50− writeRef r $ Right result
51− return result
52− Right result -> return result
53− tryGet = readRef r >>= \case
54− Left _ -> return Nothing
55− Right result -> return $ Just result
56− return (get, tryGet, invalidate)
57−
58−-- | Not thread-safe or reentrant
59−{-# INLINE memoM #-}
60−memoM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a)
61−memoM = liftM fst . cacheM
62−
63−{-# INLINE replaceRef #-}
64−replaceRef :: MonadRef m => Ref m a -> a -> m a
65−replaceRef r new = atomicModifyRef r $ \old -> (new, old)
66−
67−{-# INLINE modifyRef #-}
68−modifyRef :: MonadRef m => Ref m a -> (a -> a) -> m ()
69−modifyRef r f = atomicModifyRef r $ \a -> (f a, ())
70−
71−instance (Monoid w, MonadRef m) => MonadRef (WriterT w m) where
72− {-# SPECIALIZE instance Monoid w => MonadRef (WriterT w IO) #-}
73− type Ref (WriterT w m) = Ref m
74− newRef = lift . newRef
75− readRef = lift . readRef
76− writeRef r = lift . writeRef r
77− atomicModifyRef r f = lift $ atomicModifyRef r f
78−
79−instance MonadRef m => MonadRef (ReaderT r m) where
80− {-# SPECIALIZE instance MonadRef (ReaderT r IO) #-}
81− type Ref (ReaderT r m) = Ref m
82− newRef = lift . newRef
83− readRef = lift . readRef
84− writeRef r = lift . writeRef r
85− atomicModifyRef r f = lift $ atomicModifyRef r f
src/Reflex/Class.hs+68−5
@@ -70,9 +70,12 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
7070-- Convenience functions
7171--------------------------------------------------------------------------------
7272
73+-- | Create an Event from another Event.
74+-- The provided function can sample 'Behavior's and hold 'Event's.
7375pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
7476pushAlways f e = push (liftM Just . f) e
7577
78+-- | Flipped version of 'fmap'.
7679ffor :: Functor f => f a -> (a -> b) -> f b
7780ffor = flip fmap
7881
@@ -80,12 +83,17 @@ instance Reflex t => Functor (Behavior t) where
8083 fmap f = pull . liftM f . sample
8184
8285--TODO: See if there's a better class in the standard libraries already
86+-- | A class for values that combines filtering and mapping using 'Maybe'.
8387class FunctorMaybe f where
88+ -- | Combined mapping and filtering function.
8489 fmapMaybe :: (a -> Maybe b) -> f a -> f b
8590
91+-- | Flipped version of 'fmapMaybe'.
8692fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
8793fforMaybe = flip fmapMaybe
8894
95+-- | Filter 'f a' using the provided predicate.
96+-- Relies on 'fforMaybe'.
8997ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
9098ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
9199
@@ -95,6 +103,9 @@ instance Reflex t => FunctorMaybe (Event t) where
95103instance Reflex t => Functor (Event t) where
96104 fmap f = fmapMaybe $ Just . f
97105
106+-- | Create a new 'Event' by combining each occurence with the next value
107+-- of the list using the supplied function. If the list runs out of items,
108+-- all subsequent 'Event' occurrences will be ignored.
98109zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
99110zipListWithEvent f l e = do
100111 rec lb <- hold l eTail
@@ -107,22 +118,33 @@ zipListWithEvent f l e = do
107118 lb `seq` eBoth `seq` eTail `seq` return ()
108119 return $ fmap fst eBoth
109120
110−-- | Replace the occurrence value of the Event with the value of the Behavior at the time of the occurrence
121+-- | Replace each occurrence value of the 'Event' with the value of the
122+-- 'Behavior' at the time of that occurrence.
111123tag :: Reflex t => Behavior t b -> Event t a -> Event t b
112124tag b = pushAlways $ \_ -> sample b
113125
114−attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
115−attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
126+-- | Create a new 'Event' that combines occurences of supplied 'Event'
127+-- with the current value of the 'Behavior'.
128+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
129+attach = attachWith (,)
116130
131+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
132+-- by combining it with the current value of the 'Behavior'.
117133attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
118134attachWith f = attachWithMaybe $ \a b -> Just $ f a b
119135
120−attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
121−attach = attachWith (,)
136+-- | Create a new 'Event' by combining each occurence with the current
137+-- value of the 'Behavior'. The occurrence is discarded if the combining function
138+-- returns Nothing
139+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
140+attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
122141
142+-- | Alias for 'headE'
123143onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
124144onceE = headE
125145
146+-- | Create a new 'Event' that only occurs on the first occurence of
147+-- the supplied 'Event'.
126148headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
127149headE e = do
128150 rec be <- hold e $ fmap (const never) e'
@@ -130,24 +152,42 @@ headE e = do
130152 e' `seq` return ()
131153 return e'
132154
155+-- | Create a new 'Event' that occurs on all but the first occurence
156+-- of the supplied 'Event'.
133157tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
134158tailE e = liftM snd $ headTailE e
135159
160+-- | Create a tuple of two 'Event's with the first one occuring only
161+-- the first time the supplied 'Event' occurs and the second occuring
162+-- on all but the first occurence.
136163headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
137164headTailE e = do
138165 eHead <- headE e
139166 be <- hold never $ fmap (const e) eHead
140167 return (eHead, switch be)
141168
169+-- | Split the supplied 'Event' into two individual 'Event's occuring
170+-- at the same time with the respective values from the tuple.
142171splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
143172splitE e = (fmap fst e, fmap snd e)
144173
174+-- | Print the supplied 'String' and the value of the 'Event' on each
175+-- occurence. This should /only/ be used for debugging.
176+--
177+-- Note: As with Debug.Trace.trace, the message will only be printed if
178+-- the 'Event' is actually used.
145179traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
146180traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
147181
182+-- | Print the output of the supplied function on each occurence of
183+-- the 'Event'. This should /only/ be used for debugging.
184+--
185+-- Note: As with Debug.Trace.trace, the message will only be printed if
186+-- the 'Event' is actually used.
148187traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
149188traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
150189
190+-- | Tag type for 'Either' to use it as a 'DSum'.
151191data EitherTag l r a where
152192 LeftTag :: EitherTag l r l
153193 RightTag :: EitherTag l r r
@@ -175,16 +215,19 @@ instance (Show l, Show r) => ShowTag (EitherTag l r) where
175215 LeftTag -> showsPrec n a
176216 RightTag -> showsPrec n a
177217
218+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
178219eitherToDSum :: Either a b -> DSum (EitherTag a b)
179220eitherToDSum = \case
180221 Left a -> LeftTag :=> a
181222 Right b -> RightTag :=> b
182223
224+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
183225dsumToEither :: DSum (EitherTag a b) -> Either a b
184226dsumToEither = \case
185227 LeftTag :=> a -> Left a
186228 RightTag :=> b -> Right b
187229
230+-- | Extract the values of a 'DMap' of 'EitherTag's.
188231dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
189232dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
190233 (Nothing, Nothing) -> Nothing
@@ -192,9 +235,13 @@ dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
192235 (Nothing, Just b) -> Just $ That b
193236 (Just a, Just b) -> Just $ These a b
194237
238+-- | Create a new 'Event' that occurs if at least one of the supplied
239+-- 'Event's occurs. If both occur at the same time they are combined
240+-- using 'mappend'.
195241appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
196242appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2
197243
244+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
198245sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
199246sequenceThese t = case t of
200247 This ma -> liftM This ma
@@ -206,19 +253,33 @@ instance (Semigroup a, Reflex t) => Monoid (Event t a) where
206253 mappend a b = mconcat [a, b]
207254 mconcat = fmap sconcat . mergeList
208255
256+-- | Create a new 'Event' that occurs if at least one of the 'Event's
257+-- in the list occurs. If multiple occur at the same time they are
258+-- folded from the left with the given function.
209259mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
210260mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
211261
262+-- | Create a new 'Event' that occurs if at least one of the 'Event's
263+-- in the list occurs. If multiple occur at the same time the value is
264+-- the value of the leftmost event.
212265leftmost :: Reflex t => [Event t a] -> Event t a
213266leftmost = mergeWith const
214267
268+-- | Create a new 'Event' that occurs if at least one of the 'Event's
269+-- in the list occurs and has a list of the values of all 'Event's
270+-- occuring at that time.
215271mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
216272mergeList [] = never
217273mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
218274
275+-- | Create a new 'Event' combining the map of 'Event's into an
276+-- 'Event' that occurs if at least one of them occurs and has a map of
277+-- values of all 'Event's occuring at that time.
219278mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
220279mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
221280
281+-- | Split the event into an 'EventSelector' that allows efficient
282+-- selection of the individual 'Event's.
222283fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
223284fanMap = fan . fmap mapToDMap
224285
@@ -234,5 +295,7 @@ instance Reflex t => Align (Event t) where
234295 nil = never
235296 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
236297
298+-- | Create a new 'Event' that only occurs if the supplied 'Event'
299+-- occurs and the 'Behavior' is true at the time of occurence.
237300gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
238301gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
src/Reflex/Dynamic.hs+83−2
@@ -88,27 +88,36 @@ instance HBuild' (a ': l) r
8888 => HBuild' l (a->r) where
8989 hBuild' l x = hBuild' (HCons x l)
9090
91−
91+-- | A container for a value that can change over time and allows notifications on changes.
92+-- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
93+-- change if and only if the Event fires.
9294data Dynamic t a
9395 = Dynamic (Behavior t a) (Event t a)
9496
9597unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
9698unsafeDynamic = Dynamic
9799
100+-- | Extract the 'Behavior' of a 'Dynamic'.
98101current :: Dynamic t a -> Behavior t a
99102current (Dynamic b _) = b
100103
104+-- | Extract the 'Event' of the 'Dynamic'.
101105updated :: Dynamic t a -> Event t a
102106updated (Dynamic _ e) = e
103107
108+-- | 'Dynamic' with the constant supplied value.
104109constDyn :: Reflex t => a -> Dynamic t a
105110constDyn x = Dynamic (constant x) never
106111
112+-- | Create a 'Dynamic' using the initial value that changes every
113+-- time the 'Event' occurs.
107114holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
108115holdDyn v0 e = do
109116 b <- hold v0 e
110117 return $ Dynamic b e
111118
119+-- | Create a new 'Dynamic' that only signals changes if the values
120+-- actually changed.
112121nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
113122nubDyn d =
114123 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
@@ -123,12 +132,16 @@ instance Reflex t => Functor (Dynamic t) where
123132
124133-}
125134
135+-- | Map a function over a 'Dynamic'.
126136mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
127137mapDyn f = mapDynM $ return . f
128138
139+-- | Flipped version of 'mapDyn'.
129140forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
130141forDyn = flip mapDyn
131142
143+-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
144+-- perform is 'sample'.
132145{-# INLINE mapDynM #-}
133146mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)
134147mapDynM f d = do
@@ -139,9 +152,15 @@ mapDynM f d = do
139152 let b' = pull $ sample =<< sample bb'
140153 return $ Dynamic b' e'
141154
155+-- | Create a 'Dynamic' using the initial value and change it each
156+-- time the 'Event' occurs using a folding function on the previous
157+-- value and the value of the 'Event'.
142158foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
143159foldDyn f = foldDynM (\o v -> return $ f o v)
144160
161+-- | Create a 'Dynamic' using the initial value and change it each
162+-- time the 'Event' occurs using a monadic folding function on the
163+-- previous value and the value of the 'Event'.
145164foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
146165foldDynM f z e = do
147166 rec let e' = flip push e $ \o -> do
@@ -150,13 +169,18 @@ foldDynM f z e = do
150169 b' <- hold z e'
151170 return $ Dynamic b' e'
152171
172+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
153173count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
154174count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
155175
176+-- | Create a new 'Dynamic' using the initial value that flips its
177+-- value every time the 'Event' occurs.
156178toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
157179toggle = foldDyn (const not)
158180
159−-- | Switches to the new event whenever it receives one. Switching occurs *before* occurring the inner event.
181+-- | Switches to the new 'Event' whenever it receives one. Switching
182+-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new
183+-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.
160184switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
161185switchPromptlyDyn de =
162186 let eLag = switch $ current de
@@ -182,14 +206,19 @@ mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
182206mconcatE = concatEventsWith mappend
183207-}
184208
209+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
210+-- respective value of the tuple.
185211splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
186212splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
187213
214+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
188215mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
189216mconcatDyn es = do
190217 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
191218 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
192219
220+-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
221+-- Dynamic values.
193222distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
194223distributeDMapOverDyn dm = case DMap.toList dm of
195224 [] -> return $ constDyn DMap.empty
@@ -208,6 +237,9 @@ distributeDMapOverDyn dm = case DMap.toList dm of
208237 let bdm = pull $ sample =<< sample bbdm
209238 return $ Dynamic bdm edm
210239
240+-- | Merge two 'Dynamic's into a new one using the provided
241+-- function. The new 'Dynamic' changes its value each time one of the
242+-- original 'Dynamic's changes its value.
211243combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
212244combineDyn f da db = do
213245 let eab = align (updated da) (updated db)
@@ -234,6 +266,8 @@ tagInnerDyn e =
234266 in leftmost [eFast, eSlow]
235267-}
236268
269+-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
270+-- of the inner 'Dynamic'.
237271joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
238272joinDyn dd =
239273 let b' = pull $ sample . current =<< sample (current dd)
@@ -244,6 +278,8 @@ joinDyn dd =
244278 in Dynamic b' e'
245279
246280--TODO: Generalize this to functors other than Maps
281+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
282+-- with the current values of the 'Dynamic's in a map.
247283joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
248284joinDynThroughMap dd =
249285 let b' = pull $ mapM (sample . current) =<< sample (current dd)
@@ -258,23 +294,57 @@ joinDynThroughMap dd =
258294 e' = leftmost [eBoth, eOuter, eInner]
259295 in Dynamic b' e'
260296
297+-- | Print the value of the 'Dynamic' on each change and prefix it
298+-- with the provided string. This should /only/ be used for debugging.
299+--
300+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
301+-- else in the system is depending on it.
261302traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
262303traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
263304
305+-- | Print the result of applying the provided function to the value
306+-- of the 'Dynamic' on each change. This should /only/ be used for
307+-- debugging.
308+--
309+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
310+-- else in the system is depending on it.
264311traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
265312traceDynWith f d =
266313 let e' = traceEventWith f $ updated d
267314 in Dynamic (current d) e'
268315
316+-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
317+-- each time the 'Event' occurs.
318+--
319+-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing
320+-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`
321+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
322+-- will be used, since the 'Behavior' won't be updated until the end of the frame.
323+-- Additionally, this means that the output 'Event' may not be used to directly change
324+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
325+-- cyclic data flows, generally `tag (current d) e` is preferred.
269326tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
270327tagDyn = attachDynWith const
271328
329+-- | Attach the current value of the 'Dynamic' to the value of the
330+-- 'Event' each time it occurs.
331+--
332+-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.
272333attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
273334attachDyn = attachDynWith (,)
274335
336+-- | Combine the current value of the 'Dynamic' with the value of the
337+-- 'Event' each time it occurs.
338+--
339+-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.
275340attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
276341attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
277342
343+-- | Create a new 'Event' by combining the value at each occurence
344+-- with the current value of the 'Dynamic' value and possibly
345+-- filtering if the combining function returns 'Nothing'.
346+--
347+-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.
278348attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
279349attachDynWithMaybe f d e =
280350 let e' = attach (current d) e
@@ -287,14 +357,25 @@ attachDynWithMaybe f d e =
287357-- Demux
288358--------------------------------------------------------------------------------
289359
360+-- | Represents a time changing value together with an 'EventSelector'
361+-- that can efficiently detect when the underlying Dynamic has a particular value.
362+-- This is useful for representing data like the current selection of a long list.
363+--
364+-- Semantically,
365+-- > getDemuxed (demux d) k === mapDyn (== k) d
366+-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,
367+-- rather than /O(n)/ for mapDyn.
290368data Demux t k = Demux { demuxValue :: Behavior t k
291369 , demuxSelector :: EventSelector t (Const2 k Bool)
292370 }
293371
372+-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.
294373demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
295374demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))
296375
297376--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
377+-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
378+-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
298379getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
299380getDemuxed d k = do
300381 let e = select (demuxSelector d) (Const2 k)
src/Reflex/Dynamic/TH.hs+1−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls #-}
1+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-}
22module Reflex.Dynamic.TH (qDyn, unqDyn) where
33
44import Reflex.Dynamic
src/Reflex/Host/Class.hs+7
@@ -19,6 +19,13 @@ class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where
1919 readEvent :: EventHandle t a -> m (Maybe (m a))
2020
2121class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where
22+ -- | Creates an original Event (one that is not based on any other event).
23+ -- When a subscriber first subscribes to an event (building another event
24+ -- that depends on the subscription) the given callback function is run by
25+ -- passing a trigger. The event is then set up in IO. The callback
26+ -- function returns an accompanying teardown action.
27+ -- Any time between setup and teardown the trigger can be used to fire
28+ -- the event.
2229 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
2330
2431class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where
src/Reflex/Spider/Internal.hs+76−18
@@ -13,7 +13,9 @@ import Data.Traversable
1313import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
1414import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
1515import GHC.Exts
16+#if !MIN_VERSION_base(4,8,0)
1617import Control.Applicative
18+#endif
1719import Data.Dependent.Map (DMap, DSum (..))
1820import qualified Data.Dependent.Map as DMap
1921import Data.GADT.Compare
@@ -164,7 +166,7 @@ hold v0 e = do
164166 , holdNodeId = unsafeNodeId (v0, e)
165167#endif
166168 }
167− !s = SubscriberHold h
169+ s <- newSubscriberHold h
168170 writeIORef subscriberRef $ unsafeCoerce s
169171 modifyIORef' holdInitRef (SomeHoldInit e h :)
170172 return $ BehaviorHold h
@@ -277,7 +279,7 @@ instance GCompare k => GCompare (FanSubscriberKey k) where
277279data FanSubscribed k
278280 = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))
279281 , fanSubscribedParent :: !(EventSubscribed (DMap k))
280− , fanSubscribedSelf :: !(Subscriber (DMap k))
282+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))
281283#ifdef DEBUG_NODEIDS
282284 , fanSubscribedNodeId :: Int
283285#endif
@@ -292,9 +294,9 @@ data SwitchSubscribed a
292294 = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
293295 , switchSubscribedHeight :: !(IORef Int)
294296 , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
295− , switchSubscribedSelf :: !(Subscriber a)
297+ , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
296298 , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
297− , switchSubscribedOwnInvalidator :: !Invalidator
299+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
298300 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
299301 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
300302 , switchSubscribedParent :: !(Behavior (Event a))
@@ -313,7 +315,7 @@ data CoincidenceSubscribed a
313315 = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
314316 , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
315317 , coincidenceSubscribedHeight :: !(IORef Int)
316− , coincidenceSubscribedOuter :: !(Subscriber (Event a))
318+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
317319 , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
318320 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
319321#ifdef DEBUG_NODEIDS
@@ -390,6 +392,59 @@ data EventSubscribed a
390392 | EventSubscribedSwitch !(SwitchSubscribed a)
391393 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
392394
395+-- These function are constructor functions that are marked NOINLINE so they are
396+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
397+-- so any weak references that are attached to the constructors will have their
398+-- finalizer run. Using the opaque constructor, does not see the
399+-- constructor application, so it behaves like an IORef and cannot be fused away.
400+--
401+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
402+-- the weak pointer to it in some cases.
403+
404+{-# NOINLINE newRootSubscribed #-}
405+newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
406+newRootSubscribed occ subs =
407+ return $! RootSubscribed
408+ { rootSubscribedOccurrence = occ
409+ , rootSubscribedSubscribers = subs
410+ }
411+
412+{-# NOINLINE newSubscriberPush #-}
413+newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
414+newSubscriberPush compute subd = return $! SubscriberPush compute subd
415+
416+{-# NOINLINE newSubscriberHold #-}
417+newSubscriberHold :: Hold a -> IO (Subscriber a)
418+newSubscriberHold h = return $! SubscriberHold h
419+
420+{-# NOINLINE newSubscriberFan #-}
421+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))
422+newSubscriberFan subd = return $! SubscriberFan subd
423+
424+{-# NOINLINE newSubscriberSwitch #-}
425+newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
426+newSubscriberSwitch subd = return $! SubscriberSwitch subd
427+
428+{-# NOINLINE newSubscriberCoincidenceOuter #-}
429+newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
430+newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
431+
432+{-# NOINLINE newSubscriberCoincidenceInner #-}
433+newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
434+newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
435+
436+{-# NOINLINE newInvalidatorSwitch #-}
437+newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
438+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
439+
440+{-# NOINLINE newInvalidatorPull #-}
441+newInvalidatorPull :: Pull a -> IO Invalidator
442+newInvalidatorPull p = return $! InvalidatorPull p
443+
444+{-# NOINLINE newBox #-}
445+newBox :: a -> IO (Box a)
446+newBox a = return $! Box a
447+
393448--type role Behavior representational
394449data Behavior a
395450 = BehaviorHold !(Hold a)
@@ -605,7 +660,7 @@ data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (
605660
606661subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
607662subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
608− let !subInner = SubscriberCoincidenceInner subscribedUnsafe
663+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
609664 wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
610665 innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
611666 innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
@@ -644,7 +699,7 @@ readBehaviorTracked b = case b of
644699 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
645700 return $ pullSubscribedValue subscribed
646701 Nothing -> do
647− let !i = InvalidatorPull p
702+ i <- liftIO $ newInvalidatorPull p
648703 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
649704 parentsRef <- liftIO $ newIORef []
650705 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
@@ -776,10 +831,7 @@ getRootSubscribed r = do
776831 Just subscribed -> return subscribed
777832 Nothing -> liftIO $ do
778833 subscribersRef <- newIORef []
779− let !subscribed = RootSubscribed
780− { rootSubscribedOccurrence = rootOccurrence r
781− , rootSubscribedSubscribers = subscribersRef
782− }
834+ subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef
783835 -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
784836 uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
785837 addFinalizer subscribed $ do
@@ -797,7 +849,7 @@ getPushSubscribed p = do
797849 Just subscribed -> return subscribed
798850 Nothing -> do -- Not yet subscribed
799851 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
800− let !s = SubscriberPush (pushCompute p) subscribedUnsafe
852+ s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
801853 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
802854 subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
803855 parentOcc <- liftIO $ getEventSubscribedOcc subd
@@ -826,7 +878,7 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
826878 Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
827879 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
828880 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
829− let !s = Box subscribedUnsafe
881+ s <- liftIO $ newBox subscribedUnsafe
830882 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
831883 subscribers :: [(Any, Maybe (DSum k), Int, DSum (WrapArg EventSubscribed k))] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(WrapArg k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
832884 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
@@ -886,7 +938,7 @@ getFanSubscribed f = do
886938 Just subscribed -> return subscribed
887939 Nothing -> do
888940 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
889− let !sub = SubscriberFan subscribedUnsafe
941+ sub <- liftIO $ newSubscriberFan subscribedUnsafe
890942 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
891943 subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
892944 subscribersRef <- liftIO $ newIORef DMap.empty
@@ -909,8 +961,8 @@ getSwitchSubscribed s = do
909961 Nothing -> do
910962 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
911963 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
912− let !i = InvalidatorSwitch subscribedUnsafe
913− !sub = SubscriberSwitch subscribedUnsafe
964+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
965+ sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
914966 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
915967 wiRef <- liftIO $ newIORef wi
916968 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
@@ -951,7 +1003,7 @@ getCoincidenceSubscribed c = do
9511003 Nothing -> do
9521004 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
9531005 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
954− let !subOuter = SubscriberCoincidenceOuter subscribedUnsafe
1006+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
9551007 wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
9561008 outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
9571009 outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
@@ -1287,10 +1339,12 @@ instance MonadRef EventM where
12871339 {-# INLINE newRef #-}
12881340 {-# INLINE readRef #-}
12891341 {-# INLINE writeRef #-}
1290− {-# INLINE atomicModifyRef #-}
12911342 newRef = liftIO . newRef
12921343 readRef = liftIO . readRef
12931344 writeRef r a = liftIO $ writeRef r a
1345+
1346+instance MonadAtomicRef EventM where
1347+ {-# INLINE atomicModifyRef #-}
12941348 atomicModifyRef r f = liftIO $ atomicModifyRef r f
12951349
12961350newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
@@ -1334,6 +1388,8 @@ instance MonadRef SpiderHost where
13341388 newRef = SpiderHost . newRef
13351389 readRef = SpiderHost . readRef
13361390 writeRef r = SpiderHost . writeRef r
1391+
1392+instance MonadAtomicRef SpiderHost where
13371393 atomicModifyRef r = SpiderHost . atomicModifyRef r
13381394
13391395instance MonadRef SpiderHostFrame where
@@ -1341,4 +1397,6 @@ instance MonadRef SpiderHostFrame where
13411397 newRef = SpiderHostFrame . newRef
13421398 readRef = SpiderHostFrame . readRef
13431399 writeRef r = SpiderHostFrame . writeRef r
1400+
1401+instance MonadAtomicRef SpiderHostFrame where
13441402 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r