git.iko.soy/patch
on 7ef47af help sign in
patch/src/Reflex/Requester/Base.hs
538 lines 28 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 , withRequesterT
25 , runWithReplaceRequesterTWith
26 , traverseIntMapWithKeyWithAdjustRequesterTWith
27 , traverseDMapWithKeyWithAdjustRequesterTWith
28 , RequesterData
29 , RequesterDataKey
30 , traverseRequesterData
31 , forRequesterData
32 , requesterDataToList
33 , singletonRequesterData
34 , matchResponsesWithRequests
35 , multiEntry
36 , unMultiEntry
37 , requesting'
38 ) where
40import Reflex.Class
41import Reflex.Adjustable.Class
42import Reflex.Dynamic
43import Reflex.Host.Class
44import Reflex.PerformEvent.Class
45import Reflex.PostBuild.Class
46import Reflex.Requester.Class
47import Reflex.TriggerEvent.Class
49import Control.Applicative (liftA2)
50import Control.Monad.Exception
51import Control.Monad.Identity
52import Control.Monad.Primitive
53import Control.Monad.Reader
54import Control.Monad.Ref
55import Control.Monad.State.Strict
56import Data.Bits
57import Data.Coerce
58import Data.Dependent.Map (DMap, DSum (..))
59import qualified Data.Dependent.Map as DMap
60import Data.Functor.Compose
61import Data.Functor.Misc
62import Data.IntMap.Strict (IntMap)
63import qualified Data.IntMap.Strict as IntMap
64import Data.Map (Map)
65import qualified Data.Map as Map
66import Data.Monoid ((<>))
67import Data.Proxy
68import qualified Data.Semigroup as S
69import Data.Some (Some)
70import qualified Data.Some as Some
71import Data.Type.Equality
72import Data.Unique.Tag
74import GHC.Exts (Any)
75import Unsafe.Coerce
77--TODO: Make this module type-safe
79newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
81newtype RequesterData f = RequesterData (TagMap (Entry f))
83data RequesterDataKey a where
84 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
85 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
86 RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
87 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
89singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
90singletonRequesterData rdk v = case rdk of
91 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
92 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
93 RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
94 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
96requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
97requesterDataToList (RequesterData m) = do
98 k :=> Entry e <- tagMapToList m
99 case myKeyType k of
100 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
101 MyTagType_Multi -> do
102 (k', e') <- IntMap.toList e
103 k'' :=> e'' <- requesterDataToList e'
104 return $ RequesterDataKey_Multi k k' k'' :=> e''
105 MyTagType_Multi2 -> do
106 (k', e') <- Map.toList e
107 (k'', e'') <- IntMap.toList e'
108 k''' :=> e''' <- requesterDataToList e''
109 return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
110 MyTagType_Multi3 -> do
111 (k', e') <- IntMap.toList e
112 (k'', e'') <- IntMap.toList e'
113 k''' :=> e''' <- requesterDataToList e''
114 return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
116singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
117singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
119tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
120tagMapToList (TagMap m) = f <$> IntMap.toList m
121 where f :: (Int, Any) -> DSum MyTag f
122 f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
124traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
125traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
126 where
127 g :: Int -> Any -> t Any
128 g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
130-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
131traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
132traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
133 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
134 go k (Entry request) = Entry <$> case myKeyType k of
135 MyTagType_Single -> f request
136 MyTagType_Multi -> traverse (traverseRequesterData f) request
137 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
138 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
140-- | 'traverseRequesterData' with its arguments flipped
141forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
142forRequesterData r f = traverseRequesterData f r
144data MyTagType :: * -> * where
145 MyTagType_Single :: MyTagType (Single a)
146 MyTagType_Multi :: MyTagType Multi
147 MyTagType_Multi2 :: MyTagType (Multi2 k)
148 MyTagType_Multi3 :: MyTagType Multi3
150myKeyType :: MyTag x -> MyTagType x
151myKeyType (MyTag k) = case k .&. 0x3 of
152 0x0 -> unsafeCoerce MyTagType_Single
153 0x1 -> unsafeCoerce MyTagType_Multi
154 0x2 -> unsafeCoerce MyTagType_Multi2
155 0x3 -> unsafeCoerce MyTagType_Multi3
156 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
158data Single a
159data Multi
160data Multi2 (k :: * -> *)
161data Multi3
163class MyTagTypeOffset x where
164 myTagTypeOffset :: proxy x -> Int
166instance MyTagTypeOffset (Single a) where
167 myTagTypeOffset _ = 0x0
169instance MyTagTypeOffset Multi where
170 myTagTypeOffset _ = 0x1
172instance MyTagTypeOffset (Multi2 k) where
173 myTagTypeOffset _ = 0x2
175instance MyTagTypeOffset Multi3 where
176 myTagTypeOffset _ = 0x3
178type family EntryContents request a where
179 EntryContents request (Single a) = request a
180 EntryContents request Multi = IntMap (RequesterData request)
181 EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
182 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
184newtype Entry request x = Entry { unEntry :: EntryContents request x }
186{-# INLINE singleEntry #-}
187singleEntry :: f a -> Entry f (Single a)
188singleEntry = Entry
190{-# INLINE multiEntry #-}
191multiEntry :: IntMap (RequesterData f) -> Entry f Multi
192multiEntry = Entry
194{-# INLINE unMultiEntry #-}
195unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
196unMultiEntry = unEntry
198-- | 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
199-- 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
200newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
202newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
204{-# INLINE castMyTagWrap #-}
205castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
206castMyTagWrap = coerce
208instance GEq MyTag where
209 (MyTag a) `geq` (MyTag b) =
210 if a == b
211 then Just $ unsafeCoerce Refl
212 else Nothing
214instance GCompare MyTag where
215 (MyTag a) `gcompare` (MyTag b) =
216 case a `compare` b of
217 LT -> GLT
218 EQ -> unsafeCoerce GEQ
219 GT -> GGT
221instance GEq (MyTagWrap f) where
222 (MyTagWrap a) `geq` (MyTagWrap b) =
223 if a == b
224 then Just $ unsafeCoerce Refl
225 else Nothing
227instance GCompare (MyTagWrap f) where
228 (MyTagWrap a) `gcompare` (MyTagWrap b) =
229 case a `compare` b of
230 LT -> GLT
231 EQ -> unsafeCoerce GEQ
232 GT -> GGT
234data RequesterState t (request :: * -> *) = RequesterState
235 { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
236 , _requesterState_requests :: ![(Int, Event t Any)]
237 }
239-- | A basic implementation of 'Requester'.
240newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
241 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
242-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
243#if MIN_VERSION_base(4,9,1)
244 , MonadAsyncException
245#endif
246 )
248deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
249deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
250deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
251deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
253instance PrimMonad m => PrimMonad (RequesterT t request response m) where
254 type PrimState (RequesterT t request response m) = PrimState m
255 primitive = lift . primitive
257-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
258instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
259 mempty = pure mempty
260 mappend = liftA2 mappend
262instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
263 (<>) = liftA2 (S.<>)
266-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
267-- requests are made, and responses should be provided in the input 'Event'.
268-- The 'Tag' keys will be used to return the responses to the same place the
269-- requests were issued.
270runRequesterT :: (Reflex t, Monad m)
271 => RequesterT t request response m a
272 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
273 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
274runRequesterT (RequesterT a) responses = do
275 (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
276 coerceEvent responses
277 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
279-- | Map a function over the request and response of a 'RequesterT'
280withRequesterT
281 :: (Reflex t, MonadFix m)
282 => (forall x. req x -> req' x) -- ^ The function to map over the request
283 -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response
284 -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed
285 -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'
286withRequesterT freq frsp child = do
287 rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'
288 (a, req) <- lift $ runRequesterT child rsp
289 rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $
290 fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req
291 return a
293instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
294 type Request (RequesterT t request response m) = request
295 type Response (RequesterT t request response m) = response
296 requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
297 requesting_ = void . tagRequest . fmapCheap singleEntry
299{-# INLINE tagRequest #-}
300tagRequest :: 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))
301tagRequest req = do
302 old <- RequesterT get
303 let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
304 t = MyTagWrap n
305 RequesterT $ put $ RequesterState
306 { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
307 , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
308 }
309 return t
311{-# INLINE responseFromTag #-}
312responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
313responseFromTag (MyTagWrap t) = do
314 responses :: EventSelectorInt t Any <- RequesterT ask
315 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
317instance MonadTrans (RequesterT t request response) where
318 lift = RequesterT . lift . lift
320instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
321 type Performable (RequesterT t request response m) = Performable m
322 performEvent_ = lift . performEvent_
323 performEvent = lift . performEvent
325instance MonadRef m => MonadRef (RequesterT t request response m) where
326 type Ref (RequesterT t request response m) = Ref m
327 newRef = lift . newRef
328 readRef = lift . readRef
329 writeRef r = lift . writeRef r
331instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
332 newEventWithTrigger = lift . newEventWithTrigger
333 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
335instance MonadReader r m => MonadReader r (RequesterT t request response m) where
336 ask = lift ask
337 local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
338 reader = lift . reader
340instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
341 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
342 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
343 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
344 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
345 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
347requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
348requesting' = responseFromTag . castMyTagWrap <=< tagRequest
350{-# INLINABLE runWithReplaceRequesterTWith #-}
351runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
352 , MonadFix m
353 )
354 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
355 -> RequesterT t request response m a
356 -> Event t (RequesterT t request response m b)
357 -> RequesterT t request response m (a, Event t b)
358runWithReplaceRequesterTWith f a0 a' = do
359 rec na' <- numberOccurrencesFrom 1 a'
360 responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
361 let responses' = fanInt responses
362 ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
363 requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
364 return (result0, fmapCheap (fst . snd) v')
366{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
367traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
368 ( Reflex t
369 , MonadHold t m
370 , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
371 , Patch (p (Event t (IntMap (RequesterData request))))
372 , Functor p
373 , MonadFix m
374 )
375 => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
376 -> IntMap (IntMap.Key, v)
377 -> Event t (p (IntMap.Key, v))
378 -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
379 )
380 -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
381 -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
382 -> (IntMap.Key -> v -> RequesterT t request response m v')
383 -> IntMap v
384 -> Event t (p v)
385 -> RequesterT t request response m (IntMap v', Event t (p v'))
386traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
387 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
388 let responses :: EventSelectorInt t (IntMap (RequesterData response))
389 responses = fanInt $ fmapCheap unpack response
390 unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
391 unpack = unEntry
392 pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
393 pack = Entry
394 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
395 f' k (n, v) = do
396 (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?
397 return (fmapCheap (IntMap.singleton n) myRequests, result)
398 ndm' <- numberOccurrencesFrom 1 dm'
399 (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
400 let result0 = fmap snd children0
401 result' = fforCheap children' $ fmap snd
402 requests0 :: IntMap (Event t (IntMap (RequesterData request)))
403 requests0 = fmap fst children0
404 requests' :: Event t (p (Event t (IntMap (RequesterData request))))
405 requests' = fforCheap children' $ fmap fst
406 promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
407 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
408 requests <- holdIncremental requests0 requests'
409 return (result0, result')
411{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
412traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
413 ( GCompare k
414 , Reflex t
415 , MonadHold t m
416 , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
417 , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
418 , MonadFix m
419 )
420 => (forall k' v1 v2. GCompare k'
421 => (forall a. k' a -> v1 a -> m (v2 a))
422 -> DMap k' v1
423 -> Event t (p k' v1)
424 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
425 )
426 -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
427 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
428 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
429 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
430 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
431 -> DMap k v
432 -> Event t (p k v)
433 -> RequesterT t request response m (DMap k v', Event t (p k v'))
434traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
435 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
436 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
437 responses = fanMap $ fmapCheap unpack response
438 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
439 unpack = unEntry
440 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
441 pack = Entry
442 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
443 f' k (Compose (n, v)) = do
444 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
445 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
446 ndm' <- numberOccurrencesFrom 1 dm'
447 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
448 let result0 = DMap.map (snd . getCompose) children0
449 result' = fforCheap children' $ mapPatch $ snd . getCompose
450 requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
451 requests0 = weakenDMapWith (fst . getCompose) children0
452 requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
453 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
454 promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
455 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
456 requests <- holdIncremental requests0 requests'
457 return (result0, result')
459data Decoder rawResponse response =
460 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
462-- | Matches incoming responses with previously-sent requests
463-- and uses the provided request "decoder" function to process
464-- incoming responses.
465matchResponsesWithRequests
466 :: forall t rawRequest rawResponse request response m.
467 ( MonadFix m
468 , MonadHold t m
469 , Reflex t
470 )
471 => (forall a. request a -> (rawRequest, rawResponse -> response a))
472 -- ^ Given a request (from 'Requester'), produces the wire format of the
473 -- request and a function used to process the associated response
474 -> Event t (RequesterData request)
475 -- ^ The outgoing requests
476 -> Event t (Int, rawResponse)
477 -- ^ The incoming responses, tagged by an identifying key
478 -> m ( Event t (Map Int rawRequest)
479 , Event t (RequesterData response)
480 )
481 -- ^ A map of outgoing wire-format requests and an event of responses keyed
482 -- by the 'RequesterData' key of the associated outgoing request
483matchResponsesWithRequests f send recv = do
484 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
485 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
486 holdIncremental mempty $ leftmost
487 [ fmap (\(_, outstanding, _) -> outstanding) outgoing
488 , snd <$> incoming
489 ]
490 let outgoing = processOutgoing nextId send
491 incoming = processIncoming waitingFor recv
492 return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
493 where
494 -- Tags each outgoing request with an identifying integer key
495 -- and returns the next available key, a map of response decoders
496 -- for requests for which there are outstanding responses, and the
497 -- raw requests to be sent out.
498 processOutgoing
499 :: Behavior t Int
500 -- The next available key
501 -> Event t (RequesterData request)
502 -- The outgoing request
503 -> Event t ( Int
504 , PatchMap Int (Decoder rawResponse response)
505 , Map Int rawRequest )
506 -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
507 processOutgoing nextId out = flip pushAlways out $ \dm -> do
508 oldNextId <- sample nextId
509 let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
510 n <- get
511 put $ succ n
512 let (rawReq, rspF) = f v
513 return (n, rawReq, Decoder k rspF)
514 patchWaitingFor = PatchMap $ Map.fromList $
515 (\(n, _, dec) -> (n, Just dec)) <$> result
516 toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
517 return (newNextId, patchWaitingFor, toSend)
518 -- Looks up the each incoming raw response in a map of response
519 -- decoders and returns the decoded response and a patch that can
520 -- be used to clear the ID of the consumed response out of the queue
521 -- of expected responses.
522 processIncoming
523 :: Incremental t (PatchMap Int (Decoder rawResponse response))
524 -- A map of outstanding expected responses
525 -> Event t (Int, rawResponse)
526 -- A incoming response paired with its identifying key
527 -> Event t (RequesterData response, PatchMap Int v)
528 -- The decoded response and a patch that clears the outstanding responses queue
529 processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
530 wf <- sample $ currentIncremental waitingFor
531 case Map.lookup n wf of
532 Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
533 Just (Decoder k rspF) -> do
534 let rsp = rspF rawRsp
535 return $ Just
536 ( singletonRequesterData k rsp
537 , PatchMap $ Map.singleton n Nothing
538 )