@@ -21,7 +21,6 @@ module Reflex.Requester.Base.Internal where
22import Reflex.Class
22import Reflex.Class
23import Reflex.Adjustable.Class
23import Reflex.Adjustable.Class
25import Reflex.Host.Class
24import Reflex.Host.Class
26import Reflex.PerformEvent.Class
25import Reflex.PerformEvent.Class
27import Reflex.PostBuild.Class
26import Reflex.PostBuild.Class
@@ -36,35 +35,21 @@ import Control.Monad.Identity
36import Control.Monad.Primitive
35import Control.Monad.Primitive
37import Control.Monad.Reader
36import Control.Monad.Reader
38import Control.Monad.Ref
37import Control.Monad.Ref
39−import Control.Monad.State.Strict
41import Data.Coerce
38import Data.Coerce
42−import Data.Dependent.Map (DMap, DSum (..))
39+import Data.Dependent.Map (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
48import qualified Data.List.NonEmpty as NonEmpty
40import qualified Data.List.NonEmpty as NonEmpty
49import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
41import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
50import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
42import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
52−import qualified Data.Map as Map
53import Data.Monoid ((<>))
43import Data.Monoid ((<>))
55import qualified Data.Semigroup as S
44import qualified Data.Semigroup as S
56import Data.Some (Some(Some))
45import Data.Some (Some(Some))
57import Data.Type.Equality
46import Data.Type.Equality
58−import Data.Sequence (Seq)
59−import qualified Data.Sequence as Seq
60import Data.TagMap (TagMap)
47import Data.TagMap (TagMap)
61import qualified Data.TagMap as TagMap
48import qualified Data.TagMap as TagMap
62import Reflex.FanTag
49import Reflex.FanTag
63import Data.Unique.Tag.Local
50import Data.Unique.Tag.Local
64−import qualified Data.Unique.Tag as Global
65import Data.GADT.Compare
51import Data.GADT.Compare
66import Data.Witherable
52import Data.Witherable
69import Unsafe.Coerce
54import Unsafe.Coerce
@@ -137,21 +122,21 @@ newtype RequesterInternalT s t request response m a = RequesterInternalT { unReq
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.
141-- #if MIN_VERSION_base(4,9,1)
126-- #if MIN_VERSION_base(4,9,1)
142-- instance MonadAsyncException m => MonadAsyncException (RequesterT t request response m) where
127-- instance MonadAsyncException m => MonadAsyncException (RequesterT t request response m) where
143-- mask f = RequesterT $ mask $ \unmask -> unRequesterT $ f $ \x -> RequesterT $ unmask $ unRequesterT x
128-- mask f = RequesterT $ mask $ \unmask -> unRequesterT $ f $ \x -> RequesterT $ unmask $ unRequesterT x
146−instance MonadSample t m => MonadSample t (RequesterT t request response m)
131+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
147−instance MonadHold t m => MonadHold t (RequesterT t request response m)
132+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
148−instance PostBuild t m => PostBuild t (RequesterT t request response m)
133+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
149−instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
134+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
151−instance MonadSample t m => MonadSample t (RequesterInternalT s t request response m)
136+deriving 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)
137+deriving 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)
138+deriving 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)
139+deriving instance TriggerEvent t m => TriggerEvent t (RequesterInternalT s t request response m)
156instance PrimMonad m => PrimMonad (RequesterT t request response m) where
141instance PrimMonad m => PrimMonad (RequesterT t request response m) where
157 type PrimState (RequesterT t request response m) = PrimState m
142 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
221 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'
206 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'
222 {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}
207 {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}
223 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'
208 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'
226−import GHC.Exts (Any)
229−--TODO: Make this module type-safe
231−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
233−newtype RequesterData f = RequesterData (TagMap (Entry f))
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
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
248−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
249−requesterDataToList (RequesterData m) = do
250− k :=> Entry e <- tagMapToList m
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'''
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
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
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
279− g :: Int -> Any -> t Any
280− g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
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
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
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
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
312−data Multi2 (k :: * -> *)
315−class MyTagTypeOffset x where
316− myTagTypeOffset :: proxy x -> Int
318−instance MyTagTypeOffset (Single a) where
319− myTagTypeOffset _ = 0x0
321−instance MyTagTypeOffset Multi where
322− myTagTypeOffset _ = 0x1
324−instance MyTagTypeOffset (Multi2 k) where
325− myTagTypeOffset _ = 0x2
327−instance MyTagTypeOffset Multi3 where
328− myTagTypeOffset _ = 0x3
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))
336−newtype Entry request x = Entry { unEntry :: EntryContents request x }
338−{-# INLINE singleEntry #-}
339−singleEntry :: f a -> Entry f (Single a)
342−{-# INLINE multiEntry #-}
343−multiEntry :: IntMap (RequesterData f) -> Entry f Multi
346−{-# INLINE unMultiEntry #-}
347−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
348−unMultiEntry = unEntry
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)
354−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
356−{-# INLINE castMyTagWrap #-}
357−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
358−castMyTagWrap = coerce
360−instance GEq MyTag where
361− (MyTag a) `geq` (MyTag b) =
363− then Just $ unsafeCoerce Refl
366−instance GCompare MyTag where
367− (MyTag a) `gcompare` (MyTag b) =
368− case a `compare` b of
370− EQ -> unsafeCoerce GEQ
373−instance GEq (MyTagWrap f) where
374− (MyTagWrap a) `geq` (MyTagWrap b) =
376− then Just $ unsafeCoerce Refl
379−instance GCompare (MyTagWrap f) where
380− (MyTagWrap a) `gcompare` (MyTagWrap b) =
381− case a `compare` b of
383− EQ -> unsafeCoerce GEQ
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)]
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
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)
414−-- | Map a function over the request and response of a 'RequesterT'
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
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
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))
437− old <- RequesterT get
438− let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
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
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
452−instance MonadTrans (RequesterT t request response) where
453− lift = RequesterT . lift . lift
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
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
466−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
467− newEventWithTrigger = lift . newEventWithTrigger
468− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
470−instance MonadReader r m => MonadReader r (RequesterT t request response m) where
472− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
473− reader = lift . reader
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
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
485−{-# INLINABLE runWithReplaceRequesterTWith #-}
486−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
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')
501−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
502−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
505− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
506− , Patch (p (Event t (IntMap (RequesterData request))))
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')))
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')
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))
527− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
529− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
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')
546−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
547−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
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))))
555− => (forall k' v1 v2. GCompare k'
556− => (forall a. k' a -> v1 a -> m (v2 a))
558− -> Event t (p k' v1)
559− -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
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))
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))
575− pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
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')
594−data Decoder rawResponse response =
595− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
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.
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)
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
625− let outgoing = processOutgoing nextId send
626− incoming = processIncoming waitingFor recv
627− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
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.
635− -- The next available key
636− -> Event t (RequesterData request)
637− -- The outgoing request
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
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.
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
671− ( singletonRequesterData k rsp
672− , PatchMap $ Map.singleton n Nothing