@@ -30,6 +30,8 @@ import Reflex.Host.Class
30import Reflex.PerformEvent.Class
30import Reflex.PerformEvent.Class
31import Reflex.Requester.Base.Internal
31import Reflex.Requester.Base.Internal
32import Reflex.Requester.Class
32import Reflex.Requester.Class
33+import Reflex.EventWriter.Class
34+import Reflex.EventWriter.Base
34import Control.Lens
36import Control.Lens
35import Control.Monad.Exception
37import Control.Monad.Exception
@@ -37,13 +39,21 @@ import Control.Monad.Identity
37import Control.Monad.Primitive
39import Control.Monad.Primitive
38import Control.Monad.Reader
40import Control.Monad.Reader
39import Control.Monad.Ref
41import Control.Monad.Ref
41import Data.Dependent.Map (DMap)
42import Data.Dependent.Map (DMap)
42import qualified Data.Dependent.Map as DMap
43import qualified Data.Dependent.Map as DMap
43import Data.Dependent.Sum
44import Data.Dependent.Sum
46+import Data.Functor.Compose
47+import Data.Functor.Misc
44import Data.IntMap.Strict (IntMap)
48import Data.IntMap.Strict (IntMap)
45import qualified Data.IntMap.Strict as IntMap
49import qualified Data.IntMap.Strict as IntMap
46import qualified Data.Semigroup as S
50import qualified Data.Semigroup as S
51+import Data.Unique.Tag.Local
52+import Data.Sequence (Seq)
54+import qualified Data.TagMap as TagMap
48-- | A function that fires events for the given 'EventTrigger's and then runs
58-- | A function that fires events for the given 'EventTrigger's and then runs
49-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
59-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
@@ -75,41 +85,61 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
75 {-# INLINABLE performEvent #-}
85 {-# INLINABLE performEvent #-}
76 performEvent = PerformEventT . requestingIdentity
86 performEvent = PerformEventT . requestingIdentity
78−-- | An Adjustable instance where "adjusting" just runs the new thing - nothing is done with the old thing
79−newtype NullAdjustable t m a = NullAdjustable { unNullAdjustable :: m a }
80− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
82−instance PrimMonad m => PrimMonad (NullAdjustable t m) where
83− type PrimState (NullAdjustable t m) = PrimState m
85−instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
86− runWithReplace (PerformEventT (RequesterT a0)) a' = PerformEventT $ RequesterT $ do
87− (s, tg) <- RequesterInternalT ask
88− newA <- requestingIdentity $ undefined <$> a'
89− runWithReplace a0 never
91−instance Adjustable t (NullAdjustable t m) where
92− runWithReplace a0 a' = NullAdjustable $ do
93− return (result0, result')
94− traverseDMapWithKeyWithAdjust = defaultAdjustBase traversePatchDMapWithKey
95− traverseDMapWithKeyWithAdjustWithMove = defaultAdjustBase traversePatchDMapWithMoveWithKey
98− traverseIntMapWithKeyWithAdjust = defaultAdjustIntBase traverseIntMapPatchWithKey
102instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
88instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
103− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
89+ runWithReplace a0 a' = PerformEventT $ RequesterT $ do
104− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
90+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
105− f a0 a' = do
91+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))
92+ runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
106− result0 <- lift a0
93+ (result0, requests0) <- lift $ runA a0
107− result' <- requestingIdentity a'
94+ newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
108− return (result0, result')
95+ requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
109− traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
96+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
110− traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
97+ RequesterInternalT $ tellEvent requests
111− traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
98+ pure (result0, fmapCheap fst newA)
112−-}
99+ traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
100+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
101+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))
102+ runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
103+ children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
104+ children0 <- lift $ itraverse (\k -> runA . f k) a0
105+ let results0 = fmap fst children0
106+ requests0 = fmap snd children0
107+ results' = fmap fst <$> children'
108+ requests' = fmap snd `fmapCheap` children'
109+ requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 $ requests'
110+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
111+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
112+ pure (results0, results')
113+ traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
114+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
115+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)
116+ runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
117+ where (PerformEventT (RequesterT a)) = f k v
118+ children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
119+ children0 <- lift $ DMap.traverseWithKey runA a0
120+ let results0 = DMap.map (snd . getCompose) children0
121+ requests0 = weakenDMapWith (fst . getCompose) children0
122+ results' = mapPatchDMap (snd . getCompose) <$> children'
123+ requests' = weakenPatchDMapWith (fst . getCompose) `fmapCheap` children'
124+ requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 $ requests'
125+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
126+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
127+ pure (results0, results')
128+ traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
129+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
130+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)
131+ runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
132+ where (PerformEventT (RequesterT a)) = f k v
133+ children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
134+ children0 <- lift $ DMap.traverseWithKey runA a0
135+ let results0 = DMap.map (snd . getCompose) children0
136+ requests0 = weakenDMapWith (fst . getCompose) children0
137+ results' = mapPatchDMapWithMove (snd . getCompose) <$> children'
138+ requests' = weakenPatchDMapWithMoveWith (fst . getCompose) `fmapCheap` children'
139+ requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 $ requests'
140+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
141+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
142+ pure (results0, results')
114defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
144defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
115 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
145 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
@@ -155,8 +185,8 @@ hostPerformEventT :: forall t m a.
155 -> m (a, FireCommand t m)
185 -> m (a, FireCommand t m)
156hostPerformEventT a = do
186hostPerformEventT a = do
157 (response, responseTrigger) <- newEventWithTriggerRef
187 (response, responseTrigger) <- newEventWithTriggerRef
158− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
188+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) $ traceEventWith (const "response") response
159− eventToPerformHandle <- subscribeEvent eventToPerform
189+ eventToPerformHandle <- subscribeEvent $ traceEventWith (const "eventToPerform") eventToPerform
160 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
190 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
161 let go :: [DSum (EventTrigger t) Identity] -> m [a']
191 let go :: [DSum (EventTrigger t) Identity] -> m [a']
162 go ts = do
192 go ts = do
@@ -167,11 +197,20 @@ hostPerformEventT a = do
167 case mToPerform of
197 case mToPerform of
168 Nothing -> return [result']
198 Nothing -> return [result']
169 Just toPerform -> do
199 Just toPerform -> do
200+ traceM $ "toPerform: " <> case toPerform of
201+ RequestData _ reqs -> show (length reqs)
170 responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform
202 responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform
203+ let responseLength = case responses of
204+ ResponseData _ m -> TagMap.size m
205+ traceM $ "responses: " <> show responseLength
171 mrt <- readRef responseTrigger
206 mrt <- readRef responseTrigger
172 let followupEventTriggers = case mrt of
207 let followupEventTriggers = case mrt of
173− Just rt -> [rt :=> Identity responses]
210+ [rt :=> Identity responses]
174− Nothing -> []
211+ Nothing -> do
175 (result':) <$> go followupEventTriggers
214 (result':) <$> go followupEventTriggers
176 go triggers
215 go triggers