git.iko.soy/patch
on 4aa722a help sign in
patch/src/Reflex/Requester/Base.hs
442 lines 24 kB history raw
1-- | This module provides 'RequesterT', the standard implementation of
2-- 'Requester'.
3{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE CPP #-}
5{-# LANGUAGE EmptyDataDecls #-}
6{-# LANGUAGE ExistentialQuantification #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
18#ifdef USE_REFLEX_OPTIMIZER
19{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
20#endif
21module Reflex.Requester.Base
22 ( RequesterT (..)
23 , runRequesterT
24 , runWithReplaceRequesterTWith
25 , traverseIntMapWithKeyWithAdjustRequesterTWith
26 , traverseDMapWithKeyWithAdjustRequesterTWith
27 , RequesterData
28 , RequesterDataKey
29 , traverseRequesterData
30 , forRequesterData
31 , requesterDataToList
32 , singletonRequesterData
33 , multiEntry
34 , unMultiEntry
35 , requesting'
36 ) where
38import Reflex.Class
39import Reflex.Adjustable.Class
40import Reflex.Dynamic
41import Reflex.Host.Class
42import Reflex.PerformEvent.Class
43import Reflex.PostBuild.Class
44import Reflex.Requester.Class
45import Reflex.TriggerEvent.Class
47import Control.Applicative (liftA2)
48import Control.Monad.Exception
49import Control.Monad.Identity
50import Control.Monad.Primitive
51import Control.Monad.Reader
52import Control.Monad.Ref
53import Control.Monad.State.Strict
54import Data.Bits
55import Data.Coerce
56import Data.Dependent.Map (DMap, DSum (..))
57import qualified Data.Dependent.Map as DMap
58import Data.Functor.Compose
59import Data.Functor.Misc
60import Data.IntMap.Strict (IntMap)
61import qualified Data.IntMap.Strict as IntMap
62import Data.Map (Map)
63import qualified Data.Map as Map
64import Data.Monoid ((<>))
65import Data.Proxy
66import qualified Data.Semigroup as S
67import Data.Some (Some)
68import qualified Data.Some as Some
69import Data.Type.Equality
70import Data.Unique.Tag
72import GHC.Exts (Any)
73import Unsafe.Coerce
75--TODO: Make this module type-safe
77newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
79newtype RequesterData f = RequesterData (TagMap (Entry f))
81data RequesterDataKey a where
82 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
83 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead
84 RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
85 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
87singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
88singletonRequesterData rdk v = case rdk of
89 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
90 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
91 RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
92 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
94requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
95requesterDataToList (RequesterData m) = do
96 k :=> Entry e <- tagMapToList m
97 case myKeyType k of
98 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
99 MyTagType_Multi -> do
100 (k', e') <- IntMap.toList e
101 k'' :=> e'' <- requesterDataToList e'
102 return $ RequesterDataKey_Multi k k' k'' :=> e''
103 MyTagType_Multi2 -> do
104 (k', e') <- Map.toList e
105 (k'', e'') <- IntMap.toList e'
106 k''' :=> e''' <- requesterDataToList e''
107 return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
108 MyTagType_Multi3 -> do
109 (k', e') <- IntMap.toList e
110 (k'', e'') <- IntMap.toList e'
111 k''' :=> e''' <- requesterDataToList e''
112 return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
114singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
115singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
117tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
118tagMapToList (TagMap m) = f <$> IntMap.toList m
119 where f :: (Int, Any) -> DSum MyTag f
120 f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
122traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
123traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
124 where
125 g :: Int -> Any -> t Any
126 g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
128-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
129traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
130traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
131 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
132 go k (Entry request) = Entry <$> case myKeyType k of
133 MyTagType_Single -> f request
134 MyTagType_Multi -> traverse (traverseRequesterData f) request
135 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
136 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
138-- | 'traverseRequesterData' with its arguments flipped
139forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
140forRequesterData r f = traverseRequesterData f r
142data MyTagType :: * -> * where
143 MyTagType_Single :: MyTagType (Single a)
144 MyTagType_Multi :: MyTagType Multi
145 MyTagType_Multi2 :: MyTagType (Multi2 k)
146 MyTagType_Multi3 :: MyTagType Multi3
148myKeyType :: MyTag x -> MyTagType x
149myKeyType (MyTag k) = case k .&. 0x3 of
150 0x0 -> unsafeCoerce MyTagType_Single
151 0x1 -> unsafeCoerce MyTagType_Multi
152 0x2 -> unsafeCoerce MyTagType_Multi2
153 0x3 -> unsafeCoerce MyTagType_Multi3
154 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
156data Single a
157data Multi
158data Multi2 (k :: * -> *)
159data Multi3
161class MyTagTypeOffset x where
162 myTagTypeOffset :: proxy x -> Int
164instance MyTagTypeOffset (Single a) where
165 myTagTypeOffset _ = 0x0
167instance MyTagTypeOffset Multi where
168 myTagTypeOffset _ = 0x1
170instance MyTagTypeOffset (Multi2 k) where
171 myTagTypeOffset _ = 0x2
173instance MyTagTypeOffset Multi3 where
174 myTagTypeOffset _ = 0x3
176type family EntryContents request a where
177 EntryContents request (Single a) = request a
178 EntryContents request Multi = IntMap (RequesterData request)
179 EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
180 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
182newtype Entry request x = Entry { unEntry :: EntryContents request x }
184{-# INLINE singleEntry #-}
185singleEntry :: f a -> Entry f (Single a)
186singleEntry = Entry
188{-# INLINE multiEntry #-}
189multiEntry :: IntMap (RequesterData f) -> Entry f Multi
190multiEntry = Entry
192{-# INLINE unMultiEntry #-}
193unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
194unMultiEntry = unEntry
196-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes
197-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another
198newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
200newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
202{-# INLINE castMyTagWrap #-}
203castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
204castMyTagWrap = coerce
206instance GEq MyTag where
207 (MyTag a) `geq` (MyTag b) =
208 if a == b
209 then Just $ unsafeCoerce Refl
210 else Nothing
212instance GCompare MyTag where
213 (MyTag a) `gcompare` (MyTag b) =
214 case a `compare` b of
215 LT -> GLT
216 EQ -> unsafeCoerce GEQ
217 GT -> GGT
219instance GEq (MyTagWrap f) where
220 (MyTagWrap a) `geq` (MyTagWrap b) =
221 if a == b
222 then Just $ unsafeCoerce Refl
223 else Nothing
225instance GCompare (MyTagWrap f) where
226 (MyTagWrap a) `gcompare` (MyTagWrap b) =
227 case a `compare` b of
228 LT -> GLT
229 EQ -> unsafeCoerce GEQ
230 GT -> GGT
232data RequesterState t (request :: * -> *) = RequesterState
233 { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
234 , _requesterState_requests :: ![(Int, Event t Any)]
235 }
237-- | A basic implementation of 'Requester'.
238newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
239 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
240-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
241#if MIN_VERSION_base(4,9,1)
242 , MonadAsyncException
243#endif
244 )
246deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
247deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
248deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
249deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
251instance PrimMonad m => PrimMonad (RequesterT t request response m) where
252 type PrimState (RequesterT t request response m) = PrimState m
253 primitive = lift . primitive
255-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
256instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
257 mempty = pure mempty
258 mappend = liftA2 mappend
260instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
261 (<>) = liftA2 (S.<>)
264-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
265-- requests are made, and responses should be provided in the input 'Event'.
266-- The 'Tag' keys will be used to return the responses to the same place the
267-- requests were issued.
269runRequesterT :: (Reflex t, Monad m)
270 => RequesterT t request response m a
271 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
272 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
273runRequesterT (RequesterT a) responses = do
274 (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
275 coerceEvent responses
276 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
278instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
279 type Request (RequesterT t request response m) = request
280 type Response (RequesterT t request response m) = response
281 requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
282 requesting_ = void . tagRequest . fmapCheap singleEntry
284{-# INLINE tagRequest #-}
285tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))
286tagRequest req = do
287 old <- RequesterT get
288 let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
289 t = MyTagWrap n
290 RequesterT $ put $ RequesterState
291 { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
292 , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
293 }
294 return t
296{-# INLINE responseFromTag #-}
297responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
298responseFromTag (MyTagWrap t) = do
299 responses :: EventSelectorInt t Any <- RequesterT ask
300 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
302instance MonadTrans (RequesterT t request response) where
303 lift = RequesterT . lift . lift
305instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
306 type Performable (RequesterT t request response m) = Performable m
307 performEvent_ = lift . performEvent_
308 performEvent = lift . performEvent
310instance MonadRef m => MonadRef (RequesterT t request response m) where
311 type Ref (RequesterT t request response m) = Ref m
312 newRef = lift . newRef
313 readRef = lift . readRef
314 writeRef r = lift . writeRef r
316instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
317 newEventWithTrigger = lift . newEventWithTrigger
318 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
320instance MonadReader r m => MonadReader r (RequesterT t request response m) where
321 ask = lift ask
322 local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
323 reader = lift . reader
325instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
326 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
327 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
328 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
329 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
330 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
332requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
333requesting' = responseFromTag . castMyTagWrap <=< tagRequest
335{-# INLINABLE runWithReplaceRequesterTWith #-}
336runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
337 , MonadFix m
338 )
339 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
340 -> RequesterT t request response m a
341 -> Event t (RequesterT t request response m b)
342 -> RequesterT t request response m (a, Event t b)
343runWithReplaceRequesterTWith f a0 a' = do
344 rec na' <- numberOccurrencesFrom 1 a'
345 responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
346 let responses' = fanInt responses
347 ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
348 requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
349 return (result0, fmapCheap (fst . snd) v')
351{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
352traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
353 ( Reflex t
354 , MonadHold t m
355 , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
356 , Patch (p (Event t (IntMap (RequesterData request))))
357 , Functor p
358 , MonadFix m
359 )
360 => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
361 -> IntMap (IntMap.Key, v)
362 -> Event t (p (IntMap.Key, v))
363 -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
364 )
365 -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
366 -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
367 -> (IntMap.Key -> v -> RequesterT t request response m v')
368 -> IntMap v
369 -> Event t (p v)
370 -> RequesterT t request response m (IntMap v', Event t (p v'))
371traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
372 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
373 let responses :: EventSelectorInt t (IntMap (RequesterData response))
374 responses = fanInt $ fmapCheap unpack response
375 unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
376 unpack = unEntry
377 pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
378 pack = Entry
379 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
380 f' k (n, v) = do
381 (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
382 return (fmapCheap (IntMap.singleton n) myRequests, result)
383 ndm' <- numberOccurrencesFrom 1 dm'
384 (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable
385 let result0 = fmap snd children0
386 result' = fforCheap children' $ fmap snd
387 requests0 :: IntMap (Event t (IntMap (RequesterData request)))
388 requests0 = fmap fst children0
389 requests' :: Event t (p (Event t (IntMap (RequesterData request))))
390 requests' = fforCheap children' $ fmap fst
391 promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
392 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
393 requests <- holdIncremental requests0 requests'
394 return (result0, result')
396{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
397traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
398 ( GCompare k
399 , Reflex t
400 , MonadHold t m
401 , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
402 , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
403 , MonadFix m
404 )
405 => (forall k' v1 v2. GCompare k'
406 => (forall a. k' a -> v1 a -> m (v2 a))
407 -> DMap k' v1
408 -> Event t (p k' v1)
409 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
410 )
411 -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
412 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
413 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
414 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
415 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
416 -> DMap k v
417 -> Event t (p k v)
418 -> RequesterT t request response m (DMap k v', Event t (p k v'))
419traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
420 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
421 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
422 responses = fanMap $ fmapCheap unpack response
423 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
424 unpack = unEntry
425 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
426 pack = Entry
427 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
428 f' k (Compose (n, v)) = do
429 (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
430 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
431 ndm' <- numberOccurrencesFrom 1 dm'
432 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
433 let result0 = DMap.map (snd . getCompose) children0
434 result' = fforCheap children' $ mapPatch $ snd . getCompose
435 requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
436 requests0 = weakenDMapWith (fst . getCompose) children0
437 requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
438 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
439 promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
440 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
441 requests <- holdIncremental requests0 requests'
442 return (result0, result')