@@ -30,6 +30,8 @@ import Reflex.Host.Class
3030import Reflex.PerformEvent.Class
3131import Reflex.Requester.Base.Internal
3232import Reflex.Requester.Class
33+import Reflex.EventWriter.Class
34+import Reflex.EventWriter.Base
3335
3436import Control.Lens
3537import Control.Monad.Exception
@@ -37,13 +39,21 @@ import Control.Monad.Identity
3739import Control.Monad.Primitive
3840import Control.Monad.Reader
3941import Control.Monad.Ref
40−import Data.Coerce
4142import Data.Dependent.Map (DMap)
4243import qualified Data.Dependent.Map as DMap
4344import Data.Dependent.Sum
45+import Data.Foldable
46+import Data.Functor.Compose
47+import Data.Functor.Misc
4448import Data.IntMap.Strict (IntMap)
4549import qualified Data.IntMap.Strict as IntMap
4650import qualified Data.Semigroup as S
51+import Data.Unique.Tag.Local
52+import Data.Sequence (Seq)
53+import Data.Tuple
54+import qualified Data.TagMap as TagMap
55+
56+import Debug.Trace
4757
4858-- | A function that fires events for the given 'EventTrigger's and then runs
4959-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
@@ -75,41 +85,61 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
7585 {-# INLINABLE performEvent #-}
7686 performEvent = PerformEventT . requestingIdentity
7787
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)
81−
82−instance PrimMonad m => PrimMonad (NullAdjustable t m) where
83− type PrimState (NullAdjustable t m) = PrimState m
84−
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
90−
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
96−
97−{-
98− traverseIntMapWithKeyWithAdjust = defaultAdjustIntBase traverseIntMapPatchWithKey
99−-}
100−
101−{-
10288instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
103− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
104− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
105− f a0 a' = do
106− result0 <- lift a0
107− result' <- requestingIdentity a'
108− return (result0, result')
109− traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
110− traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
111− traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
112−-}
89+ runWithReplace a0 a' = PerformEventT $ RequesterT $ do
90+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
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
93+ (result0, requests0) <- lift $ runA a0
94+ newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
95+ requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
96+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
97+ RequesterInternalT $ tellEvent requests
98+ pure (result0, fmapCheap fst newA)
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')
113143
114144defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
115145 => ((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.
155185 -> m (a, FireCommand t m)
156186hostPerformEventT a = do
157187 (response, responseTrigger) <- newEventWithTriggerRef
158− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
159− eventToPerformHandle <- subscribeEvent eventToPerform
188+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) $ traceEventWith (const "response") response
189+ eventToPerformHandle <- subscribeEvent $ traceEventWith (const "eventToPerform") eventToPerform
160190 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
161191 let go :: [DSum (EventTrigger t) Identity] -> m [a']
162192 go ts = do
@@ -167,11 +197,20 @@ hostPerformEventT a = do
167197 case mToPerform of
168198 Nothing -> return [result']
169199 Just toPerform -> do
200+ traceM $ "toPerform: " <> case toPerform of
201+ RequestData _ reqs -> show (length reqs)
170202 responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform
203+ let responseLength = case responses of
204+ ResponseData _ m -> TagMap.size m
205+ traceM $ "responses: " <> show responseLength
171206 mrt <- readRef responseTrigger
172207 let followupEventTriggers = case mrt of
173− Just rt -> [rt :=> Identity responses]
174− Nothing -> []
208+ Just rt -> do
209+ traceM "a"
210+ [rt :=> Identity responses]
211+ Nothing -> do
212+ traceM "b"
213+ []
175214 (result':) <$> go followupEventTriggers
176215 go triggers
177216