git.iko.soy/reflex
on develop help sign in
Merge branch 'release-0.2'
48e84eeRyan Trinkle
README.mdnew file+15
compare with develop
unifiedsplit
@@ -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 @@
1{ mkDerivation, dependent-map, dependent-sum
1{ mkDerivation, dependent-map, dependent-sum
2−, mtl, semigroups, these
2+, mtl, ref-tf, semigroups, these
3}:
3}:
4mkDerivation {
4mkDerivation {
5 pname = "reflex";
5 pname = "reflex";
6 version = "0.1";
6 version = "0.1";
7 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
7 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
8 buildDepends = [
8 buildDepends = [
9− dependent-map dependent-sum mtl semigroups these
9+ dependent-map dependent-sum mtl ref-tf semigroups these
10 ];
10 ];
11 license = null;
11 license = null;
12}
12}
reflex.cabal+22−5
@@ -1,5 +1,5 @@
1Name: reflex
1Name: reflex
2−Version: 0.1.1
2+Version: 0.2
3Synopsis: Higher-order Functional Reactive Programming
3Synopsis: Higher-order Functional Reactive Programming
4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
5License: BSD3
5License: BSD3
@@ -20,11 +20,12 @@ library
20 dependent-sum == 0.2.*,
20 dependent-sum == 0.2.*,
21 dependent-map == 0.1.*,
21 dependent-map == 0.1.*,
22 semigroups == 0.16.*,
22 semigroups == 0.16.*,
23− mtl == 2.2.*,
23+ mtl >= 2.1 && < 2.3,
24 containers == 0.5.*,
24 containers == 0.5.*,
25 these == 0.4.*,
25 these == 0.4.*,
26 primitive == 0.5.*,
26 primitive == 0.5.*,
27− template-haskell >= 2.9 && < 2.11
27+ template-haskell >= 2.9 && < 2.11,
28+ ref-tf == 0.4.*
28
29
29 exposed-modules:
30 exposed-modules:
30 Reflex,
31 Reflex,
@@ -34,13 +35,29 @@ library
34 Reflex.Dynamic,
35 Reflex.Dynamic,
35 Reflex.Dynamic.TH,
36 Reflex.Dynamic.TH,
36 Reflex.Host.Class,
37 Reflex.Host.Class,
37− Data.Functor.Misc,
38+ Data.Functor.Misc
38− Control.Monad.Ref
39
39
40 other-extensions: TemplateHaskell
40 other-extensions: TemplateHaskell
41 ghc-prof-options: -fprof-auto
41 ghc-prof-options: -fprof-auto
42 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
42 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
43
43
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+
44source-repository head
61source-repository head
45 type: git
62 type: git
46 location: https://github.com/ryantrinkle/reflex
63 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
70-- Convenience functions
70-- Convenience functions
71--------------------------------------------------------------------------------
71--------------------------------------------------------------------------------
72
72
73+-- | Create an Event from another Event.
74+-- The provided function can sample 'Behavior's and hold 'Event's.
73pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
75pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
74pushAlways f e = push (liftM Just . f) e
76pushAlways f e = push (liftM Just . f) e
75
77
78+-- | Flipped version of 'fmap'.
76ffor :: Functor f => f a -> (a -> b) -> f b
79ffor :: Functor f => f a -> (a -> b) -> f b
77ffor = flip fmap
80ffor = flip fmap
78
81
@@ -80,12 +83,17 @@ instance Reflex t => Functor (Behavior t) where
80 fmap f = pull . liftM f . sample
83 fmap f = pull . liftM f . sample
81
84
82--TODO: See if there's a better class in the standard libraries already
85--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'.
83class FunctorMaybe f where
87class FunctorMaybe f where
88+ -- | Combined mapping and filtering function.
84 fmapMaybe :: (a -> Maybe b) -> f a -> f b
89 fmapMaybe :: (a -> Maybe b) -> f a -> f b
85
90
91+-- | Flipped version of 'fmapMaybe'.
86fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
92fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
87fforMaybe = flip fmapMaybe
93fforMaybe = flip fmapMaybe
88
94
95+-- | Filter 'f a' using the provided predicate.
96+-- Relies on 'fforMaybe'.
89ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
97ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
90ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
98ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
91
99
@@ -95,6 +103,9 @@ instance Reflex t => FunctorMaybe (Event t) where
95instance Reflex t => Functor (Event t) where
103instance Reflex t => Functor (Event t) where
96 fmap f = fmapMaybe $ Just . f
104 fmap f = fmapMaybe $ Just . f
97
105
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.
98zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
109zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
99zipListWithEvent f l e = do
110zipListWithEvent f l e = do
100 rec lb <- hold l eTail
111 rec lb <- hold l eTail
@@ -107,22 +118,33 @@ zipListWithEvent f l e = do
107 lb `seq` eBoth `seq` eTail `seq` return ()
118 lb `seq` eBoth `seq` eTail `seq` return ()
108 return $ fmap fst eBoth
119 return $ fmap fst eBoth
109
120
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.
111tag :: Reflex t => Behavior t b -> Event t a -> Event t b
123tag :: Reflex t => Behavior t b -> Event t a -> Event t b
112tag b = pushAlways $ \_ -> sample b
124tag b = pushAlways $ \_ -> sample b
113
125
126+-- | Create a new 'Event' that combines occurences of supplied 'Event'
127+-- with the current value of the 'Behavior'.
114−attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
128+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
115−attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
129+attach = attachWith (,)
116
130
131+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
132+-- by combining it with the current value of the 'Behavior'.
117attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
133attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
118attachWith f = attachWithMaybe $ \a b -> Just $ f a b
134attachWith f = attachWithMaybe $ \a b -> Just $ f a b
119
135
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
120−attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
139+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
121−attach = attachWith (,)
140+attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
122
141
142+-- | Alias for 'headE'
123onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
143onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
124onceE = headE
144onceE = headE
125
145
146+-- | Create a new 'Event' that only occurs on the first occurence of
147+-- the supplied 'Event'.
126headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
148headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
127headE e = do
149headE e = do
128 rec be <- hold e $ fmap (const never) e'
150 rec be <- hold e $ fmap (const never) e'
@@ -130,24 +152,42 @@ headE e = do
130 e' `seq` return ()
152 e' `seq` return ()
131 return e'
153 return e'
132
154
155+-- | Create a new 'Event' that occurs on all but the first occurence
156+-- of the supplied 'Event'.
133tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
157tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
134tailE e = liftM snd $ headTailE e
158tailE e = liftM snd $ headTailE e
135
159
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.
136headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
163headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
137headTailE e = do
164headTailE e = do
138 eHead <- headE e
165 eHead <- headE e
139 be <- hold never $ fmap (const e) eHead
166 be <- hold never $ fmap (const e) eHead
140 return (eHead, switch be)
167 return (eHead, switch be)
141
168
169+-- | Split the supplied 'Event' into two individual 'Event's occuring
170+-- at the same time with the respective values from the tuple.
142splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
171splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
143splitE e = (fmap fst e, fmap snd e)
172splitE e = (fmap fst e, fmap snd e)
144
173
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.
145traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
179traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
146traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
180traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
147
181
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.
148traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
187traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
149traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
188traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
150
189
190+-- | Tag type for 'Either' to use it as a 'DSum'.
151data EitherTag l r a where
191data EitherTag l r a where
152 LeftTag :: EitherTag l r l
192 LeftTag :: EitherTag l r l
153 RightTag :: EitherTag l r r
193 RightTag :: EitherTag l r r
@@ -175,16 +215,19 @@ instance (Show l, Show r) => ShowTag (EitherTag l r) where
175 LeftTag -> showsPrec n a
215 LeftTag -> showsPrec n a
176 RightTag -> showsPrec n a
216 RightTag -> showsPrec n a
177
217
218+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
178eitherToDSum :: Either a b -> DSum (EitherTag a b)
219eitherToDSum :: Either a b -> DSum (EitherTag a b)
179eitherToDSum = \case
220eitherToDSum = \case
180 Left a -> LeftTag :=> a
221 Left a -> LeftTag :=> a
181 Right b -> RightTag :=> b
222 Right b -> RightTag :=> b
182
223
224+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
183dsumToEither :: DSum (EitherTag a b) -> Either a b
225dsumToEither :: DSum (EitherTag a b) -> Either a b
184dsumToEither = \case
226dsumToEither = \case
185 LeftTag :=> a -> Left a
227 LeftTag :=> a -> Left a
186 RightTag :=> b -> Right b
228 RightTag :=> b -> Right b
187
229
230+-- | Extract the values of a 'DMap' of 'EitherTag's.
188dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
231dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
189dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
232dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
190 (Nothing, Nothing) -> Nothing
233 (Nothing, Nothing) -> Nothing
@@ -192,9 +235,13 @@ dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
192 (Nothing, Just b) -> Just $ That b
235 (Nothing, Just b) -> Just $ That b
193 (Just a, Just b) -> Just $ These a b
236 (Just a, Just b) -> Just $ These a b
194
237
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'.
195appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
241appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
196appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2
242appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2
197
243
244+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
198sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
245sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
199sequenceThese t = case t of
246sequenceThese t = case t of
200 This ma -> liftM This ma
247 This ma -> liftM This ma
@@ -206,19 +253,33 @@ instance (Semigroup a, Reflex t) => Monoid (Event t a) where
206 mappend a b = mconcat [a, b]
253 mappend a b = mconcat [a, b]
207 mconcat = fmap sconcat . mergeList
254 mconcat = fmap sconcat . mergeList
208
255
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.
209mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
259mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
210mergeWith 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
260mergeWith 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
211
261
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.
212leftmost :: Reflex t => [Event t a] -> Event t a
265leftmost :: Reflex t => [Event t a] -> Event t a
213leftmost = mergeWith const
266leftmost = mergeWith const
214
267
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.
215mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
271mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
216mergeList [] = never
272mergeList [] = never
217mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
273mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
218
274
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.
219mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
278mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
220mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
279mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
221
280
281+-- | Split the event into an 'EventSelector' that allows efficient
282+-- selection of the individual 'Event's.
222fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
283fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
223fanMap = fan . fmap mapToDMap
284fanMap = fan . fmap mapToDMap
224
285
@@ -234,5 +295,7 @@ instance Reflex t => Align (Event t) where
234 nil = never
295 nil = never
235 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
296 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
236
297
298+-- | Create a new 'Event' that only occurs if the supplied 'Event'
299+-- occurs and the 'Behavior' is true at the time of occurence.
237gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
300gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
238gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
301gate = 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
88 => HBuild' l (a->r) where
88 => HBuild' l (a->r) where
89 hBuild' l x = hBuild' (HCons x l)
89 hBuild' l x = hBuild' (HCons x l)
90
90
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.
92data Dynamic t a
94data Dynamic t a
93 = Dynamic (Behavior t a) (Event t a)
95 = Dynamic (Behavior t a) (Event t a)
94
96
95unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
97unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
96unsafeDynamic = Dynamic
98unsafeDynamic = Dynamic
97
99
100+-- | Extract the 'Behavior' of a 'Dynamic'.
98current :: Dynamic t a -> Behavior t a
101current :: Dynamic t a -> Behavior t a
99current (Dynamic b _) = b
102current (Dynamic b _) = b
100
103
104+-- | Extract the 'Event' of the 'Dynamic'.
101updated :: Dynamic t a -> Event t a
105updated :: Dynamic t a -> Event t a
102updated (Dynamic _ e) = e
106updated (Dynamic _ e) = e
103
107
108+-- | 'Dynamic' with the constant supplied value.
104constDyn :: Reflex t => a -> Dynamic t a
109constDyn :: Reflex t => a -> Dynamic t a
105constDyn x = Dynamic (constant x) never
110constDyn x = Dynamic (constant x) never
106
111
112+-- | Create a 'Dynamic' using the initial value that changes every
113+-- time the 'Event' occurs.
107holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
114holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
108holdDyn v0 e = do
115holdDyn v0 e = do
109 b <- hold v0 e
116 b <- hold v0 e
110 return $ Dynamic b e
117 return $ Dynamic b e
111
118
119+-- | Create a new 'Dynamic' that only signals changes if the values
120+-- actually changed.
112nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
121nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
113nubDyn d =
122nubDyn d =
114 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
123 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
123
132
124-}
133-}
125
134
135+-- | Map a function over a 'Dynamic'.
126mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
136mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
127mapDyn f = mapDynM $ return . f
137mapDyn f = mapDynM $ return . f
128
138
139+-- | Flipped version of 'mapDyn'.
129forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
140forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
130forDyn = flip mapDyn
141forDyn = flip mapDyn
131
142
143+-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
144+-- perform is 'sample'.
132{-# INLINE mapDynM #-}
145{-# INLINE mapDynM #-}
133mapDynM :: 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)
146mapDynM :: 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)
134mapDynM f d = do
147mapDynM f d = do
@@ -139,9 +152,15 @@ mapDynM f d = do
139 let b' = pull $ sample =<< sample bb'
152 let b' = pull $ sample =<< sample bb'
140 return $ Dynamic b' e'
153 return $ Dynamic b' e'
141
154
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'.
142foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
158foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
143foldDyn f = foldDynM (\o v -> return $ f o v)
159foldDyn f = foldDynM (\o v -> return $ f o v)
144
160
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'.
145foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
164foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
146foldDynM f z e = do
165foldDynM f z e = do
147 rec let e' = flip push e $ \o -> do
166 rec let e' = flip push e $ \o -> do
@@ -150,13 +169,18 @@ foldDynM f z e = do
150 b' <- hold z e'
169 b' <- hold z e'
151 return $ Dynamic b' e'
170 return $ Dynamic b' e'
152
171
172+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
153count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
173count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
154count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
174count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
155
175
176+-- | Create a new 'Dynamic' using the initial value that flips its
177+-- value every time the 'Event' occurs.
156toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
178toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
157toggle = foldDyn (const not)
179toggle = foldDyn (const not)
158
180
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'.
160switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
184switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
161switchPromptlyDyn de =
185switchPromptlyDyn de =
162 let eLag = switch $ current de
186 let eLag = switch $ current de
@@ -182,14 +206,19 @@ mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
182mconcatE = concatEventsWith mappend
206mconcatE = concatEventsWith mappend
183-}
207-}
184
208
209+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
210+-- respective value of the tuple.
185splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
211splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
186splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
212splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
187
213
214+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
188mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
215mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
189mconcatDyn es = do
216mconcatDyn es = do
190 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
217 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
191 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
218 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
192
219
220+-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
221+-- Dynamic values.
193distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
222distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
194distributeDMapOverDyn dm = case DMap.toList dm of
223distributeDMapOverDyn dm = case DMap.toList dm of
195 [] -> return $ constDyn DMap.empty
224 [] -> return $ constDyn DMap.empty
@@ -208,6 +237,9 @@ distributeDMapOverDyn dm = case DMap.toList dm of
208 let bdm = pull $ sample =<< sample bbdm
237 let bdm = pull $ sample =<< sample bbdm
209 return $ Dynamic bdm edm
238 return $ Dynamic bdm edm
210
239
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.
211combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
243combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
212combineDyn f da db = do
244combineDyn f da db = do
213 let eab = align (updated da) (updated db)
245 let eab = align (updated da) (updated db)
@@ -234,6 +266,8 @@ tagInnerDyn e =
234 in leftmost [eFast, eSlow]
266 in leftmost [eFast, eSlow]
235-}
267-}
236
268
269+-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
270+-- of the inner 'Dynamic'.
237joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
271joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
238joinDyn dd =
272joinDyn dd =
239 let b' = pull $ sample . current =<< sample (current dd)
273 let b' = pull $ sample . current =<< sample (current dd)
@@ -244,6 +278,8 @@ joinDyn dd =
244 in Dynamic b' e'
278 in Dynamic b' e'
245
279
246--TODO: Generalize this to functors other than Maps
280--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.
247joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
283joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
248joinDynThroughMap dd =
284joinDynThroughMap dd =
249 let b' = pull $ mapM (sample . current) =<< sample (current dd)
285 let b' = pull $ mapM (sample . current) =<< sample (current dd)
@@ -258,23 +294,57 @@ joinDynThroughMap dd =
258 e' = leftmost [eBoth, eOuter, eInner]
294 e' = leftmost [eBoth, eOuter, eInner]
259 in Dynamic b' e'
295 in Dynamic b' e'
260
296
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.
261traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
302traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
262traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
303traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
263
304
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.
264traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
311traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
265traceDynWith f d =
312traceDynWith f d =
266 let e' = traceEventWith f $ updated d
313 let e' = traceEventWith f $ updated d
267 in Dynamic (current d) e'
314 in Dynamic (current d) e'
268
315
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.
269tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
326tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
270tagDyn = attachDynWith const
327tagDyn = attachDynWith const
271
328
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.
272attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
333attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
273attachDyn = attachDynWith (,)
334attachDyn = attachDynWith (,)
274
335
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.
275attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
340attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
276attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
341attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
277
342
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.
278attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
348attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
279attachDynWithMaybe f d e =
349attachDynWithMaybe f d e =
280 let e' = attach (current d) e
350 let e' = attach (current d) e
@@ -287,14 +357,25 @@ attachDynWithMaybe f d e =
287-- Demux
357-- Demux
288--------------------------------------------------------------------------------
358--------------------------------------------------------------------------------
289
359
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.
290data Demux t k = Demux { demuxValue :: Behavior t k
368data Demux t k = Demux { demuxValue :: Behavior t k
291 , demuxSelector :: EventSelector t (Const2 k Bool)
369 , demuxSelector :: EventSelector t (Const2 k Bool)
292 }
370 }
293
371
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'.
294demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
373demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
295demux 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))
374demux 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))
296
375
297--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
376--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.
298getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
379getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
299getDemuxed d k = do
380getDemuxed d k = do
300 let e = select (demuxSelector d) (Const2 k)
381 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 #-}
2module Reflex.Dynamic.TH (qDyn, unqDyn) where
2module Reflex.Dynamic.TH (qDyn, unqDyn) where
3
3
4import Reflex.Dynamic
4import Reflex.Dynamic
src/Reflex/Host/Class.hs+7
@@ -19,6 +19,13 @@ class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where
19 readEvent :: EventHandle t a -> m (Maybe (m a))
19 readEvent :: EventHandle t a -> m (Maybe (m a))
20
20
21class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where
21class (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.
22 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
29 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
23
30
24class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where
31class (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
13import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
13import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
14import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
14import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
15import GHC.Exts
15import GHC.Exts
16+#if !MIN_VERSION_base(4,8,0)
16import Control.Applicative
17import Control.Applicative
18+#endif
17import Data.Dependent.Map (DMap, DSum (..))
19import Data.Dependent.Map (DMap, DSum (..))
18import qualified Data.Dependent.Map as DMap
20import qualified Data.Dependent.Map as DMap
19import Data.GADT.Compare
21import Data.GADT.Compare
@@ -164,7 +166,7 @@ hold v0 e = do
164 , holdNodeId = unsafeNodeId (v0, e)
166 , holdNodeId = unsafeNodeId (v0, e)
165#endif
167#endif
166 }
168 }
167− !s = SubscriberHold h
169+ s <- newSubscriberHold h
168 writeIORef subscriberRef $ unsafeCoerce s
170 writeIORef subscriberRef $ unsafeCoerce s
169 modifyIORef' holdInitRef (SomeHoldInit e h :)
171 modifyIORef' holdInitRef (SomeHoldInit e h :)
170 return $ BehaviorHold h
172 return $ BehaviorHold h
@@ -277,7 +279,7 @@ instance GCompare k => GCompare (FanSubscriberKey k) where
277data FanSubscribed k
279data FanSubscribed k
278 = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))
280 = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))
279 , fanSubscribedParent :: !(EventSubscribed (DMap k))
281 , fanSubscribedParent :: !(EventSubscribed (DMap k))
280− , fanSubscribedSelf :: !(Subscriber (DMap k))
282+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))
281#ifdef DEBUG_NODEIDS
283#ifdef DEBUG_NODEIDS
282 , fanSubscribedNodeId :: Int
284 , fanSubscribedNodeId :: Int
283#endif
285#endif
@@ -292,9 +294,9 @@ data SwitchSubscribed a
292 = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
294 = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
293 , switchSubscribedHeight :: !(IORef Int)
295 , switchSubscribedHeight :: !(IORef Int)
294 , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
296 , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
295− , switchSubscribedSelf :: !(Subscriber a)
297+ , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
296 , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
298 , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
297− , switchSubscribedOwnInvalidator :: !Invalidator
299+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
298 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
300 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
299 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
301 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
300 , switchSubscribedParent :: !(Behavior (Event a))
302 , switchSubscribedParent :: !(Behavior (Event a))
@@ -313,7 +315,7 @@ data CoincidenceSubscribed a
313 = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
315 = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
314 , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
316 , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
315 , coincidenceSubscribedHeight :: !(IORef Int)
317 , coincidenceSubscribedHeight :: !(IORef Int)
316− , coincidenceSubscribedOuter :: !(Subscriber (Event a))
318+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
317 , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
319 , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
318 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
320 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
319#ifdef DEBUG_NODEIDS
321#ifdef DEBUG_NODEIDS
@@ -390,6 +392,59 @@ data EventSubscribed a
390 | EventSubscribedSwitch !(SwitchSubscribed a)
392 | EventSubscribedSwitch !(SwitchSubscribed a)
391 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
393 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
392
394
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+
393--type role Behavior representational
448--type role Behavior representational
394data Behavior a
449data Behavior a
395 = BehaviorHold !(Hold a)
450 = BehaviorHold !(Hold a)
@@ -605,7 +660,7 @@ data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (
605
660
606subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
661subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
607subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
662subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
608− let !subInner = SubscriberCoincidenceInner subscribedUnsafe
663+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
609 wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
664 wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
610 innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
665 innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
611 innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
666 innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
@@ -644,7 +699,7 @@ readBehaviorTracked b = case b of
644 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
699 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
645 return $ pullSubscribedValue subscribed
700 return $ pullSubscribedValue subscribed
646 Nothing -> do
701 Nothing -> do
647− let !i = InvalidatorPull p
702+ i <- liftIO $ newInvalidatorPull p
648 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
703 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
649 parentsRef <- liftIO $ newIORef []
704 parentsRef <- liftIO $ newIORef []
650 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
705 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
@@ -776,10 +831,7 @@ getRootSubscribed r = do
776 Just subscribed -> return subscribed
831 Just subscribed -> return subscribed
777 Nothing -> liftIO $ do
832 Nothing -> liftIO $ do
778 subscribersRef <- newIORef []
833 subscribersRef <- newIORef []
779− let !subscribed = RootSubscribed
834+ subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef
780− { rootSubscribedOccurrence = rootOccurrence r
781− , rootSubscribedSubscribers = subscribersRef
782− }
783 -- 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
835 -- 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
784 uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
836 uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
785 addFinalizer subscribed $ do
837 addFinalizer subscribed $ do
@@ -797,7 +849,7 @@ getPushSubscribed p = do
797 Just subscribed -> return subscribed
849 Just subscribed -> return subscribed
798 Nothing -> do -- Not yet subscribed
850 Nothing -> do -- Not yet subscribed
799 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
851 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
800− let !s = SubscriberPush (pushCompute p) subscribedUnsafe
852+ s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
801 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
853 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
802 subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
854 subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
803 parentOcc <- liftIO $ getEventSubscribedOcc subd
855 parentOcc <- liftIO $ getEventSubscribedOcc subd
@@ -826,7 +878,7 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
826 Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
878 Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
827 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
879 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
828 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
880 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
829− let !s = Box subscribedUnsafe
881+ s <- liftIO $ newBox subscribedUnsafe
830 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
882 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
831 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
883 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
832 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
884 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
@@ -886,7 +938,7 @@ getFanSubscribed f = do
886 Just subscribed -> return subscribed
938 Just subscribed -> return subscribed
887 Nothing -> do
939 Nothing -> do
888 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
940 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
889− let !sub = SubscriberFan subscribedUnsafe
941+ sub <- liftIO $ newSubscriberFan subscribedUnsafe
890 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
942 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
891 subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
943 subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
892 subscribersRef <- liftIO $ newIORef DMap.empty
944 subscribersRef <- liftIO $ newIORef DMap.empty
@@ -909,8 +961,8 @@ getSwitchSubscribed s = do
909 Nothing -> do
961 Nothing -> do
910 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
962 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
911 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
963 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
912− let !i = InvalidatorSwitch subscribedUnsafe
964+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
913− !sub = SubscriberSwitch subscribedUnsafe
965+ sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
914 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
966 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
915 wiRef <- liftIO $ newIORef wi
967 wiRef <- liftIO $ newIORef wi
916 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
968 wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
@@ -951,7 +1003,7 @@ getCoincidenceSubscribed c = do
951 Nothing -> do
1003 Nothing -> do
952 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1004 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
953 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1005 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
954− let !subOuter = SubscriberCoincidenceOuter subscribedUnsafe
1006+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
955 wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
1007 wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
956 outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
1008 outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
957 outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
1009 outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
@@ -1287,10 +1339,12 @@ instance MonadRef EventM where
1287 {-# INLINE newRef #-}
1339 {-# INLINE newRef #-}
1288 {-# INLINE readRef #-}
1340 {-# INLINE readRef #-}
1289 {-# INLINE writeRef #-}
1341 {-# INLINE writeRef #-}
1290− {-# INLINE atomicModifyRef #-}
1291 newRef = liftIO . newRef
1342 newRef = liftIO . newRef
1292 readRef = liftIO . readRef
1343 readRef = liftIO . readRef
1293 writeRef r a = liftIO $ writeRef r a
1344 writeRef r a = liftIO $ writeRef r a
1345+
1346+instance MonadAtomicRef EventM where
1347+ {-# INLINE atomicModifyRef #-}
1294 atomicModifyRef r f = liftIO $ atomicModifyRef r f
1348 atomicModifyRef r f = liftIO $ atomicModifyRef r f
1295
1349
1296newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
1350newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
@@ -1334,6 +1388,8 @@ instance MonadRef SpiderHost where
1334 newRef = SpiderHost . newRef
1388 newRef = SpiderHost . newRef
1335 readRef = SpiderHost . readRef
1389 readRef = SpiderHost . readRef
1336 writeRef r = SpiderHost . writeRef r
1390 writeRef r = SpiderHost . writeRef r
1391+
1392+instance MonadAtomicRef SpiderHost where
1337 atomicModifyRef r = SpiderHost . atomicModifyRef r
1393 atomicModifyRef r = SpiderHost . atomicModifyRef r
1338
1394
1339instance MonadRef SpiderHostFrame where
1395instance MonadRef SpiderHostFrame where
@@ -1341,4 +1397,6 @@ instance MonadRef SpiderHostFrame where
1341 newRef = SpiderHostFrame . newRef
1397 newRef = SpiderHostFrame . newRef
1342 readRef = SpiderHostFrame . readRef
1398 readRef = SpiderHostFrame . readRef
1343 writeRef r = SpiderHostFrame . writeRef r
1399 writeRef r = SpiderHostFrame . writeRef r
1400+
1401+instance MonadAtomicRef SpiderHostFrame where
1344 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
1402 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r