git.iko.soy/reflex
on dn-minor-code-fixes help sign in
reflex/src/Reflex/Requester/Base.hs
434 lines 23 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 ) where
35import Reflex.Class
36import Reflex.Adjustable.Class
37import Reflex.Dynamic
38import Reflex.Host.Class
39import Reflex.PerformEvent.Class
40import Reflex.PostBuild.Class
41import Reflex.Requester.Class
42import Reflex.TriggerEvent.Class
44import Control.Applicative (liftA2)
45import Control.Monad.Exception
46import Control.Monad.Identity
47import Control.Monad.Reader
48import Control.Monad.Ref
49import Control.Monad.State.Strict
50import Data.Bits
51import Data.Coerce
52import Data.Dependent.Map (DMap, DSum (..))
53import qualified Data.Dependent.Map as DMap
54import Data.Functor.Compose
55import Data.Functor.Misc
56import Data.IntMap.Strict (IntMap)
57import qualified Data.IntMap.Strict as IntMap
58import Data.Map (Map)
59import qualified Data.Map as Map
60import Data.Monoid ((<>))
61import Data.Proxy
62import qualified Data.Semigroup as S
63import Data.Some (Some)
64import qualified Data.Some as Some
65import Data.Type.Equality
66import Data.Unique.Tag
68import GHC.Exts (Any)
69import Unsafe.Coerce
71--TODO: Make this module type-safe
73newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
75newtype RequesterData f = RequesterData (TagMap (Entry f))
77data RequesterDataKey a where
78 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
79 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
80 RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
81 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
83singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
84singletonRequesterData rdk v = case rdk of
85 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
86 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
87 RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
88 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
90requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
91requesterDataToList (RequesterData m) = do
92 k :=> Entry e <- tagMapToList m
93 case myKeyType k of
94 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
95 MyTagType_Multi -> do
96 (k', e') <- IntMap.toList e
97 k'' :=> e'' <- requesterDataToList e'
98 return $ RequesterDataKey_Multi k k' k'' :=> e''
99 MyTagType_Multi2 -> do
100 (k', e') <- Map.toList e
101 (k'', e'') <- IntMap.toList e'
102 k''' :=> e''' <- requesterDataToList e''
103 return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
104 MyTagType_Multi3 -> do
105 (k', e') <- IntMap.toList e
106 (k'', e'') <- IntMap.toList e'
107 k''' :=> e''' <- requesterDataToList e''
108 return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
110singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
111singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
113tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
114tagMapToList (TagMap m) = f <$> IntMap.toList m
115 where f :: (Int, Any) -> DSum MyTag f
116 f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
118traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
119traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
120 where
121 g :: Int -> Any -> t Any
122 g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
124-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
125traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
126traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
127 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
128 go k (Entry request) = Entry <$> case myKeyType k of
129 MyTagType_Single -> f request
130 MyTagType_Multi -> traverse (traverseRequesterData f) request
131 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
132 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
134-- | 'traverseRequesterData' with its arguments flipped
135forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
136forRequesterData r f = traverseRequesterData f r
138data MyTagType :: * -> * where
139 MyTagType_Single :: MyTagType (Single a)
140 MyTagType_Multi :: MyTagType Multi
141 MyTagType_Multi2 :: MyTagType (Multi2 k)
142 MyTagType_Multi3 :: MyTagType Multi3
144myKeyType :: MyTag x -> MyTagType x
145myKeyType (MyTag k) = case k .&. 0x3 of
146 0x0 -> unsafeCoerce MyTagType_Single
147 0x1 -> unsafeCoerce MyTagType_Multi
148 0x2 -> unsafeCoerce MyTagType_Multi2
149 0x3 -> unsafeCoerce MyTagType_Multi3
150 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
152data Single a
153data Multi
154data Multi2 (k :: * -> *)
155data Multi3
157class MyTagTypeOffset x where
158 myTagTypeOffset :: proxy x -> Int
160instance MyTagTypeOffset (Single a) where
161 myTagTypeOffset _ = 0x0
163instance MyTagTypeOffset Multi where
164 myTagTypeOffset _ = 0x1
166instance MyTagTypeOffset (Multi2 k) where
167 myTagTypeOffset _ = 0x2
169instance MyTagTypeOffset Multi3 where
170 myTagTypeOffset _ = 0x3
172type family EntryContents request a where
173 EntryContents request (Single a) = request a
174 EntryContents request Multi = IntMap (RequesterData request)
175 EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
176 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
178newtype Entry request x = Entry { unEntry :: EntryContents request x }
180{-# INLINE singleEntry #-}
181singleEntry :: f a -> Entry f (Single a)
182singleEntry = Entry
184{-# INLINE multiEntry #-}
185multiEntry :: IntMap (RequesterData f) -> Entry f Multi
186multiEntry = Entry
188{-# INLINE unMultiEntry #-}
189unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
190unMultiEntry = unEntry
192-- | 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
193-- 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
194newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
196newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
198{-# INLINE castMyTagWrap #-}
199castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
200castMyTagWrap = coerce
202instance GEq MyTag where
203 (MyTag a) `geq` (MyTag b) =
204 if a == b
205 then Just $ unsafeCoerce Refl
206 else Nothing
208instance GCompare MyTag where
209 (MyTag a) `gcompare` (MyTag b) =
210 case a `compare` b of
211 LT -> GLT
212 EQ -> unsafeCoerce GEQ
213 GT -> GGT
215instance GEq (MyTagWrap f) where
216 (MyTagWrap a) `geq` (MyTagWrap b) =
217 if a == b
218 then Just $ unsafeCoerce Refl
219 else Nothing
221instance GCompare (MyTagWrap f) where
222 (MyTagWrap a) `gcompare` (MyTagWrap b) =
223 case a `compare` b of
224 LT -> GLT
225 EQ -> unsafeCoerce GEQ
226 GT -> GGT
228data RequesterState t (request :: * -> *) = RequesterState
229 { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
230 , _requesterState_requests :: ![(Int, Event t Any)]
231 }
233-- | A basic implementation of 'Requester'.
234newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
235 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
236-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
237#if MIN_VERSION_base(4,9,1)
238 , MonadAsyncException
239#endif
240 )
242deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
243deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
244deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
245deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
247-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
248instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
249 mempty = pure mempty
250 mappend = liftA2 mappend
252instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
253 (<>) = liftA2 (S.<>)
256-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
257-- requests are made, and responses should be provided in the input 'Event'.
258-- The 'Tag' keys will be used to return the responses to the same place the
259-- requests were issued.
261runRequesterT :: (Reflex t, Monad m)
262 => RequesterT t request response m a
263 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
264 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
265runRequesterT (RequesterT a) responses = do
266 (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
267 coerceEvent responses
268 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
270instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
271 type Request (RequesterT t request response m) = request
272 type Response (RequesterT t request response m) = response
273 requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
274 requesting_ = void . tagRequest . fmapCheap singleEntry
276{-# INLINE tagRequest #-}
277tagRequest :: 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))
278tagRequest req = do
279 old <- RequesterT get
280 let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
281 t = MyTagWrap n
282 RequesterT $ put $ RequesterState
283 { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
284 , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
285 }
286 return t
288{-# INLINE responseFromTag #-}
289responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
290responseFromTag (MyTagWrap t) = do
291 responses :: EventSelectorInt t Any <- RequesterT ask
292 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
294instance MonadTrans (RequesterT t request response) where
295 lift = RequesterT . lift . lift
297instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
298 type Performable (RequesterT t request response m) = Performable m
299 performEvent_ = lift . performEvent_
300 performEvent = lift . performEvent
302instance MonadRef m => MonadRef (RequesterT t request response m) where
303 type Ref (RequesterT t request response m) = Ref m
304 newRef = lift . newRef
305 readRef = lift . readRef
306 writeRef r = lift . writeRef r
308instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
309 newEventWithTrigger = lift . newEventWithTrigger
310 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
312instance MonadReader r m => MonadReader r (RequesterT t request response m) where
313 ask = lift ask
314 local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
315 reader = lift . reader
317instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
318 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
319 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
320 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
321 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
322 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
324requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
325requesting' = responseFromTag . castMyTagWrap <=< tagRequest
327{-# INLINABLE runWithReplaceRequesterTWith #-}
328runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
329 , MonadFix m
330 )
331 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
332 -> RequesterT t request response m a
333 -> Event t (RequesterT t request response m b)
334 -> RequesterT t request response m (a, Event t b)
335runWithReplaceRequesterTWith f a0 a' = do
336 rec na' <- numberOccurrencesFrom 1 a'
337 responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
338 let responses' = fanInt responses
339 ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
340 requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
341 return (result0, fmapCheap (fst . snd) v')
343{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
344traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
345 ( Reflex t
346 , MonadHold t m
347 , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
348 , Patch (p (Event t (IntMap (RequesterData request))))
349 , Functor p
350 , MonadFix m
351 )
352 => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
353 -> IntMap (IntMap.Key, v)
354 -> Event t (p (IntMap.Key, v))
355 -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
356 )
357 -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
358 -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
359 -> (IntMap.Key -> v -> RequesterT t request response m v')
360 -> IntMap v
361 -> Event t (p v)
362 -> RequesterT t request response m (IntMap v', Event t (p v'))
363traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
364 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
365 let responses :: EventSelectorInt t (IntMap (RequesterData response))
366 responses = fanInt $ fmapCheap unpack response
367 unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
368 unpack = unEntry
369 pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
370 pack = Entry
371 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
372 f' k (n, v) = do
373 (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?
374 return (fmapCheap (IntMap.singleton n) myRequests, result)
375 ndm' <- numberOccurrencesFrom 1 dm'
376 (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
377 let result0 = fmap snd children0
378 result' = fforCheap children' $ fmap snd
379 requests0 :: IntMap (Event t (IntMap (RequesterData request)))
380 requests0 = fmap fst children0
381 requests' :: Event t (p (Event t (IntMap (RequesterData request))))
382 requests' = fforCheap children' $ fmap fst
383 promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
384 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
385 requests <- holdIncremental requests0 requests'
386 return (result0, result')
388{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
389traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
390 ( GCompare k
391 , Reflex t
392 , MonadHold t m
393 , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
394 , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
395 , MonadFix m
396 )
397 => (forall k' v1 v2. GCompare k'
398 => (forall a. k' a -> v1 a -> m (v2 a))
399 -> DMap k' v1
400 -> Event t (p k' v1)
401 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
402 )
403 -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
404 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
405 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
406 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
407 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
408 -> DMap k v
409 -> Event t (p k v)
410 -> RequesterT t request response m (DMap k v', Event t (p k v'))
411traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
412 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
413 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
414 responses = fanMap $ fmapCheap unpack response
415 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
416 unpack = unEntry
417 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
418 pack = Entry
419 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
420 f' k (Compose (n, v)) = do
421 (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
422 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
423 ndm' <- numberOccurrencesFrom 1 dm'
424 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
425 let result0 = DMap.map (snd . getCompose) children0
426 result' = fforCheap children' $ mapPatch $ snd . getCompose
427 requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
428 requests0 = weakenDMapWith (fst . getCompose) children0
429 requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
430 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
431 promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
432 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
433 requests <- holdIncremental requests0 requests'
434 return (result0, result')