@@ -21,7 +21,6 @@ module Reflex.Requester.Base.Internal where
2121
2222import Reflex.Class
2323import Reflex.Adjustable.Class
24−import Reflex.Dynamic
2524import Reflex.Host.Class
2625import Reflex.PerformEvent.Class
2726import Reflex.PostBuild.Class
@@ -36,35 +35,21 @@ import Control.Monad.Identity
3635import Control.Monad.Primitive
3736import Control.Monad.Reader
3837import Control.Monad.Ref
39−import Control.Monad.State.Strict
40−import Data.Bits
4138import Data.Coerce
42−import Data.Dependent.Map (DMap, DSum (..))
43−import qualified Data.Dependent.Map as DMap
44−import Data.Functor.Compose
45−import Data.Functor.Misc
46−import Data.IntMap.Strict (IntMap)
47−import qualified Data.IntMap.Strict as IntMap
39+import Data.Dependent.Map (DSum (..))
4840import qualified Data.List.NonEmpty as NonEmpty
4941import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
5042import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
51−import Data.Map (Map)
52−import qualified Data.Map as Map
5343import Data.Monoid ((<>))
54−import Data.Proxy
5544import qualified Data.Semigroup as S
5645import Data.Some (Some(Some))
5746import Data.Type.Equality
58−import Data.Sequence (Seq)
59−import qualified Data.Sequence as Seq
6047import Data.TagMap (TagMap)
6148import qualified Data.TagMap as TagMap
6249import Reflex.FanTag
6350import Data.Unique.Tag.Local
64−import qualified Data.Unique.Tag as Global
6551import Data.GADT.Compare
6652import Data.Witherable
67−import Data.Foldable
6853
6954import Unsafe.Coerce
7055
@@ -137,21 +122,21 @@ newtype RequesterInternalT s t request response m a = RequesterInternalT { unReq
137122#endif
138123 )
139124
140−-- I don't think this can actually be supported without an unsafeCoerce
125+-- I don't think this can actually be supported without unsafeCoercing around the fact that the phantoms don't match up. In fact, implementations could probably supply `unmask` functions that would actually do the wrong thing.
141126-- #if MIN_VERSION_base(4,9,1)
142127-- instance MonadAsyncException m => MonadAsyncException (RequesterT t request response m) where
143128-- mask f = RequesterT $ mask $ \unmask -> unRequesterT $ f $ \x -> RequesterT $ unmask $ unRequesterT x
144129-- #endif
145130
146−instance MonadSample t m => MonadSample t (RequesterT t request response m)
147−instance MonadHold t m => MonadHold t (RequesterT t request response m)
148−instance PostBuild t m => PostBuild t (RequesterT t request response m)
149−instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
131+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
132+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
133+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
134+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
150135
151−instance MonadSample t m => MonadSample t (RequesterInternalT s t request response m)
152−instance MonadHold t m => MonadHold t (RequesterInternalT s t request response m)
153−instance PostBuild t m => PostBuild t (RequesterInternalT s t request response m)
154−instance TriggerEvent t m => TriggerEvent t (RequesterInternalT s t request response m)
136+deriving instance MonadSample t m => MonadSample t (RequesterInternalT s t request response m)
137+deriving instance MonadHold t m => MonadHold t (RequesterInternalT s t request response m)
138+deriving instance PostBuild t m => PostBuild t (RequesterInternalT s t request response m)
139+deriving instance TriggerEvent t m => TriggerEvent t (RequesterInternalT s t request response m)
155140
156141instance PrimMonad m => PrimMonad (RequesterT t request response m) where
157142 type PrimState (RequesterT t request response m) = PrimState m
@@ -221,454 +206,3 @@ instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterT t request r
221206 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'
222207 {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}
223208 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'
224−
225−{-
226−import GHC.Exts (Any)
227−import Unsafe.Coerce
228−
229−--TODO: Make this module type-safe
230−
231−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
232−
233−newtype RequesterData f = RequesterData (TagMap (Entry f))
234−
235−data RequesterDataKey a where
236− RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
237− 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
238− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
239− RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
240−
241−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
242−singletonRequesterData rdk v = case rdk of
243− RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
244− RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
245− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
246− RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
247−
248−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
249−requesterDataToList (RequesterData m) = do
250− k :=> Entry e <- tagMapToList m
251− case myKeyType k of
252− MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
253− MyTagType_Multi -> do
254− (k', e') <- IntMap.toList e
255− k'' :=> e'' <- requesterDataToList e'
256− return $ RequesterDataKey_Multi k k' k'' :=> e''
257− MyTagType_Multi2 -> do
258− (k', e') <- Map.toList e
259− (k'', e'') <- IntMap.toList e'
260− k''' :=> e''' <- requesterDataToList e''
261− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
262− MyTagType_Multi3 -> do
263− (k', e') <- IntMap.toList e
264− (k'', e'') <- IntMap.toList e'
265− k''' :=> e''' <- requesterDataToList e''
266− return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
267−
268−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
269−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
270−
271−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
272−tagMapToList (TagMap m) = f <$> IntMap.toList m
273− where f :: (Int, Any) -> DSum MyTag f
274− f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
275−
276−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
277−traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
278− where
279− g :: Int -> Any -> t Any
280− g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
281−
282−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
283−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
284−traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
285− where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
286− go k (Entry request) = Entry <$> case myKeyType k of
287− MyTagType_Single -> f request
288− MyTagType_Multi -> traverse (traverseRequesterData f) request
289− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
290− MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
291−
292−-- | 'traverseRequesterData' with its arguments flipped
293−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
294−forRequesterData r f = traverseRequesterData f r
295−
296−data MyTagType :: * -> * where
297− MyTagType_Single :: MyTagType (Single a)
298− MyTagType_Multi :: MyTagType Multi
299− MyTagType_Multi2 :: MyTagType (Multi2 k)
300− MyTagType_Multi3 :: MyTagType Multi3
301−
302−myKeyType :: MyTag x -> MyTagType x
303−myKeyType (MyTag k) = case k .&. 0x3 of
304− 0x0 -> unsafeCoerce MyTagType_Single
305− 0x1 -> unsafeCoerce MyTagType_Multi
306− 0x2 -> unsafeCoerce MyTagType_Multi2
307− 0x3 -> unsafeCoerce MyTagType_Multi3
308− t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
309−
310−data Single a
311−data Multi
312−data Multi2 (k :: * -> *)
313−data Multi3
314−
315−class MyTagTypeOffset x where
316− myTagTypeOffset :: proxy x -> Int
317−
318−instance MyTagTypeOffset (Single a) where
319− myTagTypeOffset _ = 0x0
320−
321−instance MyTagTypeOffset Multi where
322− myTagTypeOffset _ = 0x1
323−
324−instance MyTagTypeOffset (Multi2 k) where
325− myTagTypeOffset _ = 0x2
326−
327−instance MyTagTypeOffset Multi3 where
328− myTagTypeOffset _ = 0x3
329−
330−type family EntryContents request a where
331− EntryContents request (Single a) = request a
332− EntryContents request Multi = IntMap (RequesterData request)
333− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
334− EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
335−
336−newtype Entry request x = Entry { unEntry :: EntryContents request x }
337−
338−{-# INLINE singleEntry #-}
339−singleEntry :: f a -> Entry f (Single a)
340−singleEntry = Entry
341−
342−{-# INLINE multiEntry #-}
343−multiEntry :: IntMap (RequesterData f) -> Entry f Multi
344−multiEntry = Entry
345−
346−{-# INLINE unMultiEntry #-}
347−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
348−unMultiEntry = unEntry
349−
350−-- | 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
351−-- 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
352−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
353−
354−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
355−
356−{-# INLINE castMyTagWrap #-}
357−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
358−castMyTagWrap = coerce
359−
360−instance GEq MyTag where
361− (MyTag a) `geq` (MyTag b) =
362− if a == b
363− then Just $ unsafeCoerce Refl
364− else Nothing
365−
366−instance GCompare MyTag where
367− (MyTag a) `gcompare` (MyTag b) =
368− case a `compare` b of
369− LT -> GLT
370− EQ -> unsafeCoerce GEQ
371− GT -> GGT
372−
373−instance GEq (MyTagWrap f) where
374− (MyTagWrap a) `geq` (MyTagWrap b) =
375− if a == b
376− then Just $ unsafeCoerce Refl
377− else Nothing
378−
379−instance GCompare (MyTagWrap f) where
380− (MyTagWrap a) `gcompare` (MyTagWrap b) =
381− case a `compare` b of
382− LT -> GLT
383− EQ -> unsafeCoerce GEQ
384− GT -> GGT
385−
386−data RequesterState t (request :: * -> *) = RequesterState
387− { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
388− , _requesterState_requests :: ![(Int, Event t Any)]
389− }
390−
391−-- | A basic implementation of 'Requester'.
392−newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
393− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
394−-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
395−#if MIN_VERSION_base(4,9,1)
396− , MonadAsyncException
397−#endif
398− )
399−
400−
401−-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
402−-- requests are made, and responses should be provided in the input 'Event'.
403−-- The 'Tag' keys will be used to return the responses to the same place the
404−-- requests were issued.
405−runRequesterT :: (Reflex t, Monad m)
406− => RequesterT t request response m a
407− -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
408− -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
409−runRequesterT (RequesterT a) responses = do
410− (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
411− coerceEvent responses
412− return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
413−
414−-- | Map a function over the request and response of a 'RequesterT'
415−withRequesterT
416− :: (Reflex t, MonadFix m)
417− => (forall x. req x -> req' x) -- ^ The function to map over the request
418− -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response
419− -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed
420− -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'
421−withRequesterT freq frsp child = do
422− rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'
423− (a, req) <- lift $ runRequesterT child rsp
424− rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $
425− fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req
426− return a
427−
428−instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
429− type Request (RequesterT t request response m) = request
430− type Response (RequesterT t request response m) = response
431− requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
432− requesting_ = void . tagRequest . fmapCheap singleEntry
433−
434−{-# INLINE tagRequest #-}
435−tagRequest :: 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))
436−tagRequest req = do
437− old <- RequesterT get
438− let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
439− t = MyTagWrap n
440− RequesterT $ put $ RequesterState
441− { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
442− , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
443− }
444− return t
445−
446−{-# INLINE responseFromTag #-}
447−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
448−responseFromTag (MyTagWrap t) = do
449− responses :: EventSelectorInt t Any <- RequesterT ask
450− return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
451−
452−instance MonadTrans (RequesterT t request response) where
453− lift = RequesterT . lift . lift
454−
455−instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
456− type Performable (RequesterT t request response m) = Performable m
457− performEvent_ = lift . performEvent_
458− performEvent = lift . performEvent
459−
460−instance MonadRef m => MonadRef (RequesterT t request response m) where
461− type Ref (RequesterT t request response m) = Ref m
462− newRef = lift . newRef
463− readRef = lift . readRef
464− writeRef r = lift . writeRef r
465−
466−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
467− newEventWithTrigger = lift . newEventWithTrigger
468− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
469−
470−instance MonadReader r m => MonadReader r (RequesterT t request response m) where
471− ask = lift ask
472− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
473− reader = lift . reader
474−
475−instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
476− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
477− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
478− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
479− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
480− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
481−
482−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
483−requesting' = responseFromTag . castMyTagWrap <=< tagRequest
484−
485−{-# INLINABLE runWithReplaceRequesterTWith #-}
486−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
487− , MonadFix m
488− )
489− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
490− -> RequesterT t request response m a
491− -> Event t (RequesterT t request response m b)
492− -> RequesterT t request response m (a, Event t b)
493−runWithReplaceRequesterTWith f a0 a' = do
494− rec na' <- numberOccurrencesFrom 1 a'
495− responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
496− let responses' = fanInt responses
497− ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
498− requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
499− return (result0, fmapCheap (fst . snd) v')
500−
501−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
502−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
503− ( Reflex t
504− , MonadHold t m
505− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
506− , Patch (p (Event t (IntMap (RequesterData request))))
507− , Functor p
508− , MonadFix m
509− )
510− => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
511− -> IntMap (IntMap.Key, v)
512− -> Event t (p (IntMap.Key, v))
513− -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
514− )
515− -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
516− -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
517− -> (IntMap.Key -> v -> RequesterT t request response m v')
518− -> IntMap v
519− -> Event t (p v)
520− -> RequesterT t request response m (IntMap v', Event t (p v'))
521−traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
522− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
523− let responses :: EventSelectorInt t (IntMap (RequesterData response))
524− responses = fanInt $ fmapCheap unpack response
525− unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
526− unpack = unEntry
527− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
528− pack = Entry
529− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
530− f' k (n, v) = do
531− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
532− return (fmapCheap (IntMap.singleton n) myRequests, result)
533− ndm' <- numberOccurrencesFrom 1 dm'
534− (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
535− let result0 = fmap snd children0
536− result' = fforCheap children' $ fmap snd
537− requests0 :: IntMap (Event t (IntMap (RequesterData request)))
538− requests0 = fmap fst children0
539− requests' :: Event t (p (Event t (IntMap (RequesterData request))))
540− requests' = fforCheap children' $ fmap fst
541− promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
542− promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
543− requests <- holdIncremental requests0 requests'
544− return (result0, result')
545−
546−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
547−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
548− ( GCompare k
549− , Reflex t
550− , MonadHold t m
551− , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
552− , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
553− , MonadFix m
554− )
555− => (forall k' v1 v2. GCompare k'
556− => (forall a. k' a -> v1 a -> m (v2 a))
557− -> DMap k' v1
558− -> Event t (p k' v1)
559− -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
560− )
561− -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
562− -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
563− -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
564− -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
565− -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
566− -> DMap k v
567− -> Event t (p k v)
568− -> RequesterT t request response m (DMap k v', Event t (p k v'))
569−traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
570− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
571− let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
572− responses = fanMap $ fmapCheap unpack response
573− unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
574− unpack = unEntry
575− pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
576− pack = Entry
577− f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
578− f' k (Compose (n, v)) = do
579− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
580− return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
581− ndm' <- numberOccurrencesFrom 1 dm'
582− (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
583− let result0 = DMap.map (snd . getCompose) children0
584− result' = fforCheap children' $ mapPatch $ snd . getCompose
585− requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
586− requests0 = weakenDMapWith (fst . getCompose) children0
587− requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
588− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
589− promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
590− promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
591− requests <- holdIncremental requests0 requests'
592− return (result0, result')
593−
594−data Decoder rawResponse response =
595− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
596−
597−-- | Matches incoming responses with previously-sent requests
598−-- and uses the provided request "decoder" function to process
599−-- incoming responses.
600−matchResponsesWithRequests
601− :: forall t rawRequest rawResponse request response m.
602− ( MonadFix m
603− , MonadHold t m
604− , Reflex t
605− )
606− => (forall a. request a -> (rawRequest, rawResponse -> response a))
607− -- ^ Given a request (from 'Requester'), produces the wire format of the
608− -- request and a function used to process the associated response
609− -> Event t (RequesterData request)
610− -- ^ The outgoing requests
611− -> Event t (Int, rawResponse)
612− -- ^ The incoming responses, tagged by an identifying key
613− -> m ( Event t (Map Int rawRequest)
614− , Event t (RequesterData response)
615− )
616− -- ^ A map of outgoing wire-format requests and an event of responses keyed
617− -- by the 'RequesterData' key of the associated outgoing request
618−matchResponsesWithRequests f send recv = do
619− rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
620− waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
621− holdIncremental mempty $ leftmost
622− [ fmap (\(_, outstanding, _) -> outstanding) outgoing
623− , snd <$> incoming
624− ]
625− let outgoing = processOutgoing nextId send
626− incoming = processIncoming waitingFor recv
627− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
628− where
629− -- Tags each outgoing request with an identifying integer key
630− -- and returns the next available key, a map of response decoders
631− -- for requests for which there are outstanding responses, and the
632− -- raw requests to be sent out.
633− processOutgoing
634− :: Behavior t Int
635− -- The next available key
636− -> Event t (RequesterData request)
637− -- The outgoing request
638− -> Event t ( Int
639− , PatchMap Int (Decoder rawResponse response)
640− , Map Int rawRequest )
641− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
642− processOutgoing nextId out = flip pushAlways out $ \dm -> do
643− oldNextId <- sample nextId
644− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
645− n <- get
646− put $ succ n
647− let (rawReq, rspF) = f v
648− return (n, rawReq, Decoder k rspF)
649− patchWaitingFor = PatchMap $ Map.fromList $
650− (\(n, _, dec) -> (n, Just dec)) <$> result
651− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
652− return (newNextId, patchWaitingFor, toSend)
653− -- Looks up the each incoming raw response in a map of response
654− -- decoders and returns the decoded response and a patch that can
655− -- be used to clear the ID of the consumed response out of the queue
656− -- of expected responses.
657− processIncoming
658− :: Incremental t (PatchMap Int (Decoder rawResponse response))
659− -- A map of outstanding expected responses
660− -> Event t (Int, rawResponse)
661− -- A incoming response paired with its identifying key
662− -> Event t (RequesterData response, PatchMap Int v)
663− -- The decoded response and a patch that clears the outstanding responses queue
664− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
665− wf <- sample $ currentIncremental waitingFor
666− case Map.lookup n wf of
667− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
668− Just (Decoder k rspF) -> do
669− let rsp = rspF rawRsp
670− return $ Just
671− ( singletonRequesterData k rsp
672− , PatchMap $ Map.singleton n Nothing
673− )
674−-}