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