git.iko.soy/patch
on develop help sign in
Merge branch 'develop' into is-monoidal-containers-dep
95e0744Luigy Leon
bench-cbits/checkCapability.c+6−6
compare with develop
unifiedsplit
@@ -42,7 +42,7 @@ typedef struct Task_ {
42 // or just continue immediately. It's a workaround for the fact
42 // or just continue immediately. It's a workaround for the fact
43 // that signalling a condition variable doesn't do anything if the
43 // that signalling a condition variable doesn't do anything if the
44 // thread is already running, but we want it to be sticky.
44 // thread is already running, but we want it to be sticky.
45− bool wakeup;
45+ HsBool wakeup;
46#endif
46#endif
47
47
48 // This points to the Capability that the Task "belongs" to. If
48 // This points to the Capability that the Task "belongs" to. If
@@ -65,11 +65,11 @@ typedef struct Task_ {
65 uint32_t n_spare_incalls;
65 uint32_t n_spare_incalls;
66 struct InCall_ *spare_incalls;
66 struct InCall_ *spare_incalls;
67
67
68− bool worker; // == rtsTrue if this is a worker Task
68+ HsBool worker; // == rtsTrue if this is a worker Task
69− bool stopped; // this task has stopped or exited Haskell
69+ HsBool stopped; // this task has stopped or exited Haskell
70
70
71 // So that we can detect when a finalizer illegally calls back into Haskell
71 // So that we can detect when a finalizer illegally calls back into Haskell
72− bool running_finalizers;
72+ HsBool running_finalizers;
73
73
74 // Links tasks on the returning_tasks queue of a Capability, and
74 // Links tasks on the returning_tasks queue of a Capability, and
75 // on spare_workers.
75 // on spare_workers.
@@ -98,12 +98,12 @@ struct Capability_ {
98
98
99 // true if this Capability is running Haskell code, used for
99 // true if this Capability is running Haskell code, used for
100 // catching unsafe call-ins.
100 // catching unsafe call-ins.
101− bool in_haskell;
101+ HsBool in_haskell;
102
102
103 // Has there been any activity on this Capability since the last GC?
103 // Has there been any activity on this Capability since the last GC?
104 uint32_t idle;
104 uint32_t idle;
105
105
106− bool disabled;
106+ HsBool disabled;
107
107
108 // The run queue. The Task owning this Capability has exclusive
108 // The run queue. The Task owning this Capability has exclusive
109 // access to its run queue, so can wake up threads without
109 // access to its run queue, so can wake up threads without
reflex.cabal+3
@@ -73,6 +73,8 @@ library
73 Reflex,
73 Reflex,
74 Reflex.Class,
74 Reflex.Class,
75 Reflex.Adjustable.Class,
75 Reflex.Adjustable.Class,
76+ Reflex.BehaviorWriter.Base,
77+ Reflex.BehaviorWriter.Class,
76 Reflex.Collection,
78 Reflex.Collection,
77 Reflex.Dynamic,
79 Reflex.Dynamic,
78 Reflex.Dynamic.Uniq,
80 Reflex.Dynamic.Uniq,
@@ -208,6 +210,7 @@ test-suite EventWriterT
208 build-depends: base
210 build-depends: base
209 , containers
211 , containers
210 , deepseq >= 1.3 && < 1.5
212 , deepseq >= 1.3 && < 1.5
213+ , dependent-map
211 , dependent-sum
214 , dependent-sum
212 , lens
215 , lens
213 , mtl
216 , mtl
src/Data/AppendMap.hs+4
@@ -26,7 +26,11 @@ import Prelude hiding (map, null)
26import Data.Coerce
26import Data.Coerce
27import Data.Default
27import Data.Default
28import Data.Map (Map)
28import Data.Map (Map)
29+#if MIN_VERSION_containers(0,5,11)
29import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)
30import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)
31+#else
32+import qualified Data.Map as Map (showTree, showTreeWith)
33+#endif
30import Data.Map.Monoidal
34import Data.Map.Monoidal
31import Reflex.Class (FunctorMaybe (..))
35import Reflex.Class (FunctorMaybe (..))
32import Reflex.Patch (Additive, Group (..))
36import Reflex.Patch (Additive, Group (..))
src/Reflex.hs+2
@@ -7,6 +7,8 @@ module Reflex
7
7
8import Reflex.Class as X
8import Reflex.Class as X
9import Reflex.Adjustable.Class as X
9import Reflex.Adjustable.Class as X
10+import Reflex.BehaviorWriter.Base as X
11+import Reflex.BehaviorWriter.Class as X
10import Reflex.Collection as X
12import Reflex.Collection as X
11import Reflex.Dynamic as X
13import Reflex.Dynamic as X
12import Reflex.EventWriter.Base as X
14import Reflex.EventWriter.Base as X
src/Reflex/BehaviorWriter/Base.hsnew file+204
@@ -0,0 +1,204 @@
1+{-|
2+Module: Reflex.BehaviorWriter.Base
3+Description: Implementation of MonadBehaviorWriter
4+-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE StandaloneDeriving #-}
17+#ifdef USE_REFLEX_OPTIMIZER
18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
19+#endif
20+module Reflex.BehaviorWriter.Base
21+ ( BehaviorWriterT (..)
22+ , runBehaviorWriterT
23+ , withBehaviorWriterT
24+ ) where
25+
26+import Control.Monad.Exception
27+import Control.Monad.Identity
28+import Control.Monad.IO.Class
29+import Control.Monad.Reader
30+import Control.Monad.Ref
31+import Control.Monad.State.Strict
32+import Data.Dependent.Map (DMap)
33+import qualified Data.Dependent.Map as DMap
34+import Data.Functor.Misc
35+import Data.IntMap (IntMap)
36+import qualified Data.IntMap as IntMap
37+import Data.Map (Map)
38+import qualified Data.Map as Map
39+import Data.Some (Some)
40+
41+import Reflex.Class
42+import Reflex.Adjustable.Class
43+import Reflex.BehaviorWriter.Class
44+import Reflex.Host.Class
45+import Reflex.PerformEvent.Class
46+import Reflex.PostBuild.Class
47+import Reflex.Query.Class
48+import Reflex.Requester.Class
49+import Reflex.TriggerEvent.Class
50+
51+-- | A basic implementation of 'MonadBehaviorWriter'.
52+newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
53+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
54+
55+-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
56+-- along with the result of the action.
57+runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)
58+runBehaviorWriterT (BehaviorWriterT a) = do
59+ (result, ws) <- runStateT a []
60+ return (result, mconcat $ reverse ws)
61+
62+-- | Map a function over the output of a 'BehaviorWriterT'.
63+withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)
64+ => (w -> w')
65+ -> BehaviorWriterT t w m a
66+ -> BehaviorWriterT t w' m a
67+withBehaviorWriterT f dw = do
68+ (r, d) <- lift $ do
69+ (r, d) <- runBehaviorWriterT dw
70+ let d' = fmap f d
71+ return (r, d')
72+ tellBehavior d
73+ return r
74+
75+deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
76+deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
77+
78+instance MonadTrans (BehaviorWriterT t w) where
79+ lift = BehaviorWriterT . lift
80+
81+instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
82+ type Ref (BehaviorWriterT t w m) = Ref m
83+ newRef = lift . newRef
84+ readRef = lift . readRef
85+ writeRef r = lift . writeRef r
86+
87+instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where
88+ atomicModifyRef r = lift . atomicModifyRef r
89+
90+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where
91+ newEventWithTrigger = lift . newEventWithTrigger
92+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
93+
94+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
95+ tellBehavior w = BehaviorWriterT $ modify (w :)
96+
97+instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
98+ ask = lift ask
99+ local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a
100+ reader = lift . reader
101+
102+instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where
103+ type Performable (BehaviorWriterT t w m) = Performable m
104+ performEvent_ = lift . performEvent_
105+ performEvent = lift . performEvent
106+
107+instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where
108+ newTriggerEvent = lift newTriggerEvent
109+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
110+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
111+
112+instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where
113+ getPostBuild = lift getPostBuild
114+
115+instance MonadState s m => MonadState s (BehaviorWriterT t w m) where
116+ get = lift get
117+ put = lift . put
118+
119+instance Requester t m => Requester t (BehaviorWriterT t w m) where
120+ type Request (BehaviorWriterT t w m) = Request m
121+ type Response (BehaviorWriterT t w m) = Response m
122+ requesting = lift . requesting
123+ requesting_ = lift . requesting_
124+
125+instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where
126+ tellQueryIncremental = lift . tellQueryIncremental
127+ askQueryResult = lift askQueryResult
128+ queryIncremental = lift . queryIncremental
129+
130+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where
131+ runWithReplace a0 a' = do
132+ (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'
133+ tellBehavior . join =<< hold (snd result0) (snd <$> result')
134+ return (fst result0, fst <$> result')
135+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust
136+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith
137+
138+traverseIntMapWithKeyWithAdjustImpl
139+ :: forall t w v' p p' v m.
140+ ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)
141+ , Patch (p' (Behavior t w))
142+ , Monoid w
143+ , Reflex t
144+ , MonadHold t m
145+ , Functor p
146+ , p ~ p'
147+ )
148+ => ( (IntMap.Key -> v -> m (v', Behavior t w))
149+ -> IntMap v
150+ -> Event t (p v)
151+ -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
152+ )
153+ -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
154+ -> IntMap v
155+ -> Event t (p v)
156+ -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
157+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
158+ (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
159+ let liftedResult0 = fmap fst result0
160+ liftedResult' = fmap (fmap fst) result'
161+ liftedWritten0 :: IntMap (Behavior t w)
162+ liftedWritten0 = fmap snd result0
163+ liftedWritten' = fmap (fmap snd) result'
164+ i <- holdIncremental liftedWritten0 liftedWritten'
165+ tellBehavior $ pull $ do
166+ m <- sample $ currentIncremental i
167+ mconcat . IntMap.elems <$> traverse sample m
168+ return (liftedResult0, liftedResult')
169+
170+newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
171+
172+traverseDMapWithKeyWithAdjustImpl
173+ :: forall t w k v' p p' v m.
174+ ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
175+ , Patch (p' (Some k) (Behavior t w))
176+ , Monoid w
177+ , Reflex t
178+ , MonadHold t m
179+ )
180+ => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
181+ -> DMap k v
182+ -> Event t (p k v)
183+ -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
184+ )
185+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
186+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
187+ -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
188+ -> DMap k v
189+ -> Event t (p k v)
190+ -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
191+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
192+ (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
193+ let getValue (BehaviorWriterTLoweredResult (v, _)) = v
194+ getWritten (BehaviorWriterTLoweredResult (_, w)) = w
195+ liftedResult0 = DMap.map getValue result0
196+ liftedResult' = ffor result' $ mapPatch getValue
197+ liftedWritten0 :: Map (Some k) (Behavior t w)
198+ liftedWritten0 = weakenDMapWith getWritten result0
199+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
200+ i <- holdIncremental liftedWritten0 liftedWritten'
201+ tellBehavior $ pull $ do
202+ m <- sample $ currentIncremental i
203+ mconcat . Map.elems <$> traverse sample m
204+ return (liftedResult0, liftedResult')
src/Reflex/BehaviorWriter/Class.hsnew file+26
@@ -0,0 +1,26 @@
1+{-|
2+Module: Reflex.BehaviorWriter.Class
3+Description: This module defines the 'MonadBehaviorWriter' class
4+-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+#ifdef USE_REFLEX_OPTIMIZER
11+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12+#endif
13+module Reflex.BehaviorWriter.Class
14+ ( MonadBehaviorWriter (..)
15+ ) where
16+
17+import Control.Monad.Reader (ReaderT, lift)
18+import Reflex.Class (Behavior)
19+
20+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
21+-- and combines them monoidally to provide a 'Behavior' result.
22+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where
23+ tellBehavior :: Behavior t w -> m ()
24+
25+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where
26+ tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+58
@@ -44,9 +44,13 @@ module Reflex.Class
44 -- ** Combining 'Event's
44 -- ** Combining 'Event's
45 , leftmost
45 , leftmost
46 , mergeMap
46 , mergeMap
47+ , mergeIntMap
47 , mergeMapIncremental
48 , mergeMapIncremental
48 , mergeMapIncrementalWithMove
49 , mergeMapIncrementalWithMove
49 , mergeIntMapIncremental
50 , mergeIntMapIncremental
51+ , coincidencePatchMap
52+ , coincidencePatchMapWithMove
53+ , coincidencePatchIntMap
50 , mergeList
54 , mergeList
51 , mergeWith
55 , mergeWith
52 , difference
56 , difference
@@ -66,6 +70,7 @@ module Reflex.Class
66 , switchHold
70 , switchHold
67 , switchHoldPromptly
71 , switchHoldPromptly
68 , switchHoldPromptOnly
72 , switchHoldPromptOnly
73+ , switchHoldPromptOnlyIncremental
69 -- ** Using 'Event's to sample 'Behavior's
74 -- ** Using 'Event's to sample 'Behavior's
70 , tag
75 , tag
71 , tagMaybe
76 , tagMaybe
@@ -191,6 +196,7 @@ import Data.These
191import Data.Type.Coercion
196import Data.Type.Coercion
192import Reflex.FunctorMaybe
197import Reflex.FunctorMaybe
193import Reflex.Patch
198import Reflex.Patch
199+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
194
200
195import Debug.Trace (trace)
201import Debug.Trace (trace)
196
202
@@ -781,6 +787,10 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn
781mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
787mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
782mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
788mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
783
789
790+-- | Like 'mergeMap' but for 'IntMap'.
791+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
792+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap
793+
784-- | Create a merge whose parents can change over time
794-- | Create a merge whose parents can change over time
785mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
795mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
786mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
796mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
@@ -859,6 +869,54 @@ switchHoldPromptOnly e0 e' = do
859 eLag <- switch <$> hold e0 e'
869 eLag <- switch <$> hold e0 e'
860 return $ coincidence $ leftmost [e', eLag <$ eLag]
870 return $ coincidence $ leftmost [e', eLag <$ eLag]
861
871
872+-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.
873+coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)
874+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case
875+ Nothing -> fmapCheap (const Nothing) e
876+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
877+
878+-- | See 'coincicencePatchMap'
879+coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)
880+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case
881+ Nothing -> fmapCheap (const Nothing) e
882+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
883+
884+-- | See 'coincicencePatchMap'
885+coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)
886+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of
887+ PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->
888+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
889+ PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->
890+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }
891+ PatchMapWithMove.From_Insert ev -> leftmost
892+ [ fforCheap ev $ \v ->
893+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }
894+ , fforCheap e $ \_ ->
895+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
896+ ]
897+
898+switchHoldPromptOnlyIncremental
899+ :: forall t m p pt w
900+ . ( Reflex t
901+ , MonadHold t m
902+ , Patch (p (Event t w))
903+ , PatchTarget (p (Event t w)) ~ pt (Event t w)
904+ , Patch (p w)
905+ , PatchTarget (p w) ~ pt w
906+ , Monoid (pt w)
907+ )
908+ => (Incremental t (p (Event t w)) -> Event t (pt w))
909+ -> (Event t (p (Event t w)) -> Event t (p w))
910+ -> pt (Event t w)
911+ -> Event t (p (Event t w))
912+ -> m (Event t (pt w))
913+switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do
914+ lag <- mergePatchIncremental <$> holdIncremental e0 e'
915+ pure $ ffor (align lag (coincidencePatch e')) $ \case
916+ This old -> old
917+ That new -> new `applyAlways` mempty
918+ These old new -> new `applyAlways` old
919+
862instance Reflex t => Align (Event t) where
920instance Reflex t => Align (Event t) where
863 nil = never
921 nil = never
864 align = alignEventWithMaybe Just
922 align = alignEventWithMaybe Just
src/Reflex/DynamicWriter/Base.hs+5−1
@@ -38,9 +38,10 @@ import Data.Semigroup
38import Data.Some (Some)
38import Data.Some (Some)
39import Data.These
39import Data.These
40
40
41−import Reflex.Class
42import Reflex.Adjustable.Class
41import Reflex.Adjustable.Class
42+import Reflex.Class
43import Reflex.DynamicWriter.Class
43import Reflex.DynamicWriter.Class
44+import Reflex.EventWriter.Class (EventWriter, tellEvent)
44import Reflex.Host.Class
45import Reflex.Host.Class
45import qualified Reflex.Patch.MapWithMove as MapWithMove
46import qualified Reflex.Patch.MapWithMove as MapWithMove
46import Reflex.PerformEvent.Class
47import Reflex.PerformEvent.Class
@@ -226,3 +227,6 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) wh
226 tellQueryIncremental = lift . tellQueryIncremental
227 tellQueryIncremental = lift . tellQueryIncremental
227 askQueryResult = lift askQueryResult
228 askQueryResult = lift askQueryResult
228 queryIncremental = lift . queryIncremental
229 queryIncremental = lift . queryIncremental
230+
231+instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
232+ tellEvent = lift . tellEvent
src/Reflex/EventWriter/Base.hs+68−54
@@ -22,9 +22,10 @@ module Reflex.EventWriter.Base
22 , withEventWriterT
22 , withEventWriterT
23 ) where
23 ) where
24
24
25−import Reflex.Class
26import Reflex.Adjustable.Class
25import Reflex.Adjustable.Class
26+import Reflex.Class
27import Reflex.EventWriter.Class (EventWriter, tellEvent)
27import Reflex.EventWriter.Class (EventWriter, tellEvent)
28+import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn)
28import Reflex.Host.Class
29import Reflex.Host.Class
29import Reflex.PerformEvent.Class
30import Reflex.PerformEvent.Class
30import Reflex.PostBuild.Class
31import Reflex.PostBuild.Class
@@ -40,7 +41,6 @@ import Control.Monad.Ref
40import Control.Monad.State.Strict
41import Control.Monad.State.Strict
41import Data.Dependent.Map (DMap, DSum (..))
42import Data.Dependent.Map (DMap, DSum (..))
42import qualified Data.Dependent.Map as DMap
43import qualified Data.Dependent.Map as DMap
43−import Data.Foldable
44import Data.Functor.Compose
44import Data.Functor.Compose
45import Data.Functor.Misc
45import Data.Functor.Misc
46import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
46import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -48,10 +48,11 @@ import Data.IntMap.Strict (IntMap)
48import qualified Data.IntMap.Strict as IntMap
48import qualified Data.IntMap.Strict as IntMap
49import Data.List.NonEmpty (NonEmpty (..))
49import Data.List.NonEmpty (NonEmpty (..))
50import Data.Map (Map)
50import Data.Map (Map)
51+import qualified Data.Map as Map
51import Data.Semigroup
52import Data.Semigroup
52import Data.Some (Some)
53import Data.Some (Some)
53import Data.Tuple
54import Data.Tuple
54−import Data.Type.Equality
55+import Data.Type.Equality hiding (apply)
55
56
56import Unsafe.Coerce
57import Unsafe.Coerce
57
58
@@ -135,9 +136,9 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
135
136
136instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
137instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
137 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
138 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
138− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
139+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap
139− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
140+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap
140− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
141+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove
141
142
142instance Requester t m => Requester t (EventWriterT t w m) where
143instance Requester t m => Requester t (EventWriterT t w m) where
143 type Request (EventWriterT t w m) = Request m
144 type Request (EventWriterT t w m) = Request m
@@ -160,19 +161,29 @@ runWithReplaceEventWriterTWith f a0 a' = do
160 return (fst result0, fmapCheap fst result')
161 return (fst result0, fmapCheap fst result')
161
162
162-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
163-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
163−sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
164+sequenceIntMapWithAdjustEventWriterTWith
165+ :: forall t m p w v v'
166+ . ( Reflex t
167+ , MonadHold t m
168+ , Semigroup w
169+ , Functor p
170+ , Patch (p (Event t w))
171+ , PatchTarget (p (Event t w)) ~ IntMap (Event t w)
172+ , Patch (p w)
173+ , PatchTarget (p w) ~ IntMap w
174+ )
164− => ( (IntMap.Key -> v -> m (Event t w, v'))
175+ => ( (IntMap.Key -> v -> m (Event t w, v'))
165− -> IntMap v
176+ -> IntMap v
166− -> Event t (p v)
177+ -> Event t (p v)
167− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
178+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
168− )
179+ )
169− -> (p (Event t w) -> [Event t w])
170− -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
180+ -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))
181+ -> (Event t (p (Event t w)) -> Event t (p w))
171− -> (IntMap.Key -> v -> EventWriterT t w m v')
182+ -> (IntMap.Key -> v -> EventWriterT t w m v')
172− -> IntMap v
183+ -> IntMap v
173− -> Event t (p v)
184+ -> Event t (p v)
174− -> EventWriterT t w m (IntMap v', Event t (p v'))
185+ -> EventWriterT t w m (IntMap v', Event t (p v'))
175−sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
186+sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do
176 let f' :: IntMap.Key -> v -> m (Event t w, v')
187 let f' :: IntMap.Key -> v -> m (Event t w, v')
177 f' k v = swap <$> runEventWriterT (f k v)
188 f' k v = swap <$> runEventWriterT (f k v)
178 (children0, children') <- base f' dm0 dm'
189 (children0, children') <- base f' dm0 dm'
@@ -182,26 +193,39 @@ sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncreme
182 requests0 = fmap fst children0
193 requests0 = fmap fst children0
183 requests' :: Event t (p (Event t w))
194 requests' :: Event t (p (Event t w))
184 requests' = fmapCheap (fmap fst) children'
195 requests' = fmapCheap (fmap fst) children'
185− childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
196+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
186− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
197+ tellEvent $ fforMaybeCheap e $ \m ->
198+ case IntMap.elems m of
199+ [] -> Nothing
200+ h : t -> Just $ sconcat $ h :| t
187 return (result0, result')
201 return (result0, result')
188
202
189-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
203-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
204+sequenceDMapWithAdjustEventWriterTWith
205+ :: forall t m p p' w k v v'
206+ . ( Reflex t
207+ , MonadHold t m
208+ , Semigroup w
209+ , Patch (p' (Some k) (Event t w))
190−sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
210+ , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)
211+ , GCompare k
212+ , Patch (p' (Some k) w)
213+ , PatchTarget (p' (Some k) w) ~ Map (Some k) w
214+ )
191− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
215+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
192− -> DMap k v
216+ -> DMap k v
193− -> Event t (p k v)
217+ -> Event t (p k v)
194− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
218+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
195− )
219+ )
196− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
220+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
197− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
221+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
198− -> (p' (Some k) (Event t w) -> [Event t w])
199− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
222+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))
223+ -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))
200− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
224+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
201− -> DMap k v
225+ -> DMap k v
202− -> Event t (p k v)
226+ -> Event t (p k v)
203− -> EventWriterT t w m (DMap k v', Event t (p k v'))
227+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
204−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
228+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do
205 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
229 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
206 f' k v = Compose . swap <$> runEventWriterT (f k v)
230 f' k v = Compose . swap <$> runEventWriterT (f k v)
207 (children0, children') <- base f' dm0 dm'
231 (children0, children') <- base f' dm0 dm'
@@ -211,26 +235,13 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewEle
211 requests0 = weakenDMapWith (fst . getCompose) children0
235 requests0 = weakenDMapWith (fst . getCompose) children0
212 requests' :: Event t (p' (Some k) (Event t w))
236 requests' :: Event t (p' (Some k) (Event t w))
213 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
237 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
214− childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
238+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
215− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
239+ tellEvent $ fforMaybeCheap e $ \m ->
240+ case Map.elems m of
241+ [] -> Nothing
242+ h : t -> Just $ sconcat $ h :| t
216 return (result0, result')
243 return (result0, result')
217
244
218−tellEventsPromptly
219− :: ( Foldable f
220− , Reflex t
221− , MonadHold t m
222− , EventWriter t w m
223− )
224− => Event t a
225− -> (a -> [Event t w])
226− -> Event t (f w)
227− -> m ()
228−tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
229− let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
230− [] -> Nothing
231− h : t -> Just $ sconcat $ h :| t
232− tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')
233−
234instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
245instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
235 type Performable (EventWriterT t w m) = Performable m
246 type Performable (EventWriterT t w m) = Performable m
236 performEvent_ = lift . performEvent_
247 performEvent_ = lift . performEvent_
@@ -267,6 +278,9 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher
267 askQueryResult = lift askQueryResult
278 askQueryResult = lift askQueryResult
268 queryIncremental = lift . queryIncremental
279 queryIncremental = lift . queryIncremental
269
280
281+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where
282+ tellDyn = lift . tellDyn
283+
270instance PrimMonad m => PrimMonad (EventWriterT t w m) where
284instance PrimMonad m => PrimMonad (EventWriterT t w m) where
271 type PrimState (EventWriterT t w m) = PrimState m
285 type PrimState (EventWriterT t w m) = PrimState m
272 primitive = lift . primitive
286 primitive = lift . primitive
src/Reflex/FunctorMaybe.hs+10
@@ -4,6 +4,10 @@ module Reflex.FunctorMaybe
4 ( FunctorMaybe (..)
4 ( FunctorMaybe (..)
5 ) where
5 ) where
6
6
7+import Data.IntMap (IntMap)
8+import qualified Data.IntMap as IntMap
9+import Data.Map (Map)
10+import qualified Data.Map as Map
7import Data.Maybe
11import Data.Maybe
8
12
9--TODO: See if there's a better class in the standard libraries already
13--TODO: See if there's a better class in the standard libraries already
@@ -31,3 +35,9 @@ instance FunctorMaybe Maybe where
31-- | @fmapMaybe = mapMaybe@
35-- | @fmapMaybe = mapMaybe@
32instance FunctorMaybe [] where
36instance FunctorMaybe [] where
33 fmapMaybe = mapMaybe
37 fmapMaybe = mapMaybe
38+
39+instance FunctorMaybe (Map k) where
40+ fmapMaybe = Map.mapMaybe
41+
42+instance FunctorMaybe IntMap where
43+ fmapMaybe = IntMap.mapMaybe
src/Reflex/Optimizer.hs+5
@@ -16,6 +16,11 @@ import Control.Arrow
16import CoreMonad
16import CoreMonad
17import Data.String
17import Data.String
18import GhcPlugins
18import GhcPlugins
19+
20+#if MIN_VERSION_base(4,9,0)
21+import Prelude hiding ((<>))
22+#endif
23+
19#endif
24#endif
20
25
21#ifdef ghcjs_HOST_OS
26#ifdef ghcjs_HOST_OS
src/Reflex/Query/Base.hs−7
@@ -278,13 +278,6 @@ instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
278instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
278instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
279 (<>) = liftA2 (S.<>)
279 (<>) = liftA2 (S.<>)
280
280
281−
282−mapQuery :: QueryMorphism q q' -> q -> q'
283−mapQuery = _queryMorphism_mapQuery
284−
285−mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
286−mapQueryResult = _queryMorphism_mapQueryResult
287−
288-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
281-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
289withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
282withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
290 => QueryMorphism q q'
283 => QueryMorphism q q'
src/Reflex/Query/Class.hs+23
@@ -15,12 +15,18 @@ module Reflex.Query.Class
15 , MonadQuery (..)
15 , MonadQuery (..)
16 , tellQueryDyn
16 , tellQueryDyn
17 , queryDyn
17 , queryDyn
18+ , mapQuery
19+ , mapQueryResult
18 ) where
20 ) where
19
21
22+import Control.Category (Category)
23+import qualified Control.Category as Cat
20import Control.Monad.Reader
24import Control.Monad.Reader
21import Data.Bits
25import Data.Bits
22import Data.Data
26import Data.Data
23import Data.Ix
27import Data.Ix
28+import Data.Map.Monoidal (MonoidalMap)
29+import qualified Data.Map.Monoidal as MonoidalMap
24import Data.Semigroup
30import Data.Semigroup
25import Foreign.Storable
31import Foreign.Storable
26
32
@@ -30,6 +36,10 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
30 type QueryResult a :: *
36 type QueryResult a :: *
31 crop :: a -> QueryResult a -> QueryResult a
37 crop :: a -> QueryResult a -> QueryResult a
32
38
39+instance (Ord k, Query v) => Query (MonoidalMap k v) where
40+ type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
41+ crop q r = MonoidalMap.intersectionWith (flip crop) r q
42+
33-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
43-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
34-- and compatible with the query relationship when acting on the query result
44-- and compatible with the query relationship when acting on the query result
35data QueryMorphism q q' = QueryMorphism
45data QueryMorphism q q' = QueryMorphism
@@ -37,6 +47,19 @@ data QueryMorphism q q' = QueryMorphism
37 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
47 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
38 }
48 }
39
49
50+instance Category QueryMorphism where
51+ id = QueryMorphism id id
52+ qm . qm' = QueryMorphism
53+ { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
54+ , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
55+ }
56+
57+mapQuery :: QueryMorphism q q' -> q -> q'
58+mapQuery = _queryMorphism_mapQuery
59+
60+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
61+mapQueryResult = _queryMorphism_mapQueryResult
62+
40-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
63-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
41newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
64newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
42 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
65 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
test/EventWriterT.hs+52−3
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
2{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4module Main where
5module Main where
@@ -6,6 +7,9 @@ module Main where
6import Control.Lens
7import Control.Lens
7import Control.Monad
8import Control.Monad
8import Control.Monad.Fix
9import Control.Monad.Fix
10+import qualified Data.Dependent.Map as DMap
11+import Data.Functor.Misc
12+import qualified Data.Map as M
9import Data.These
13import Data.These
10
14
11import Reflex
15import Reflex
@@ -28,6 +32,10 @@ main = do
28 print os2
32 print os2
29 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
33 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
30 print os3
34 print os3
35+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]
36+ print os4
37+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
38+ print os5
31 return ()
39 return ()
32
40
33unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
41unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -59,7 +67,48 @@ testMoribundTellEvent
59 => Event t ()
67 => Event t ()
60 -> EventWriterT t [Int] m ()
68 -> EventWriterT t [Int] m ()
61testMoribundTellEvent pulse = do
69testMoribundTellEvent pulse = do
62− rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
63− tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
64− (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
72+ (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse
73+ return ()
74+
75+-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.
76+testMoribundTellEventDMap
77+ :: forall t m
78+ . ( Reflex t
79+ , Adjustable t m
80+ , MonadHold t m
81+ , MonadFix m
82+ )
83+ => Event t ()
84+ -> EventWriterT t [Int] m ()
85+testMoribundTellEventDMap pulse = do
86+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
87+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
88+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
89+ traverseDMapWithKeyWithAdjust
90+ (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)
91+ (mapToDMap $ M.singleton () 1)
92+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
93+ return ()
94+
95+-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's
96+-- during the same frame as other elements are updated.
97+testLiveTellEventDMap
98+ :: forall t m
99+ . ( Reflex t
100+ , Adjustable t m
101+ , MonadHold t m
102+ , MonadFix m
103+ )
104+ => Event t ()
105+ -> EventWriterT t [Int] m ()
106+testLiveTellEventDMap pulse = do
107+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
108+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
109+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
110+ traverseDMapWithKeyWithAdjust
111+ (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)
112+ (mapToDMap $ M.singleton 1 ())
113+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
65 return ()
114 return ()
test/Reflex/Test/CrossImpl.hs+1
@@ -30,6 +30,7 @@ import Data.Foldable
30import Data.Map.Strict (Map)
30import Data.Map.Strict (Map)
31import qualified Data.Map.Strict as Map
31import qualified Data.Map.Strict as Map
32import qualified Data.Set as Set
32import qualified Data.Set as Set
33+import Data.Monoid
33import Data.Traversable
34import Data.Traversable
34import System.Exit
35import System.Exit
35import System.Mem
36import System.Mem