git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/Requester/Base.hs
607 lines 32 kB history raw
1-- | This module provides 'RequesterT', the standard implementation of
2-- 'Requester'.
3{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE ApplicativeDo #-}
5{-# LANGUAGE CPP #-}
6{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE ExistentialQuantification #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE Rank2Types #-}
13{-# LANGUAGE RecursiveDo #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE StandaloneDeriving #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19#ifdef USE_REFLEX_OPTIMIZER
20{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21#endif
22module Reflex.Requester.Base
23 ( RequesterT (..)
24 , runRequesterT
25 , withRequesterT
26 , runWithReplaceRequesterTWith
27 , traverseIntMapWithKeyWithAdjustRequesterTWith
28 , traverseDMapWithKeyWithAdjustRequesterTWith
29 , RequesterData
30 , RequesterDataKey
31 , traverseRequesterData
32 , forRequesterData
33 , requesterDataToList
34 , singletonRequesterData
35 , matchResponsesWithRequests
36 , matchResponseMapWithRequests
37 , multiEntry
38 , unMultiEntry
39 , requesting'
40 ) where
42import Reflex.Class
43import Reflex.Adjustable.Class
44import Reflex.Dynamic
45import Reflex.Host.Class
46import Reflex.PerformEvent.Class
47import Reflex.PostBuild.Class
48import Reflex.Requester.Class
49import Reflex.TriggerEvent.Class
51import Control.Applicative (liftA2)
52import Control.Monad.Exception
53import Control.Monad.Identity
54import Control.Monad.Morph
55import Control.Monad.Primitive
56import Control.Monad.Reader
57import Control.Monad.Ref
58import Control.Monad.State.Strict
59import Data.Bits
60import Data.Coerce
61import Data.Constraint
62import Data.Dependent.Map (DMap)
63import qualified Data.Dependent.Map as DMap
64import Data.Dependent.Sum (DSum (..))
65import Data.Functor.Compose
66import Data.Functor.Misc
67import Data.IntMap.Strict (IntMap)
68import qualified Data.IntMap.Strict as IntMap
69import Data.Map (Map)
70import qualified Data.Map as Map
71import Data.Monoid ((<>))
72import Data.Proxy
73import qualified Data.Semigroup as S
74import Data.Some (Some(Some))
75import Data.Type.Equality
76import Data.Unique.Tag
78import GHC.Exts (Any)
79import Unsafe.Coerce
81--TODO: Make this module type-safe
83newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
85newtype RequesterData f = RequesterData (TagMap (Entry f))
87emptyRequesterData :: RequesterData f
88emptyRequesterData = RequesterData $ TagMap IntMap.empty
90data RequesterDataKey a where
91 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
92 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
93 RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
94 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
97singletonRequesterData rdk v = case rdk of
98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
99 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
100 RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents
101 { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
102 , _multi2Contents_dict = Dict
103 }
104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
106mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f
107mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b
109mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)
110mergeTagMap (TagMap m) (TagMap n) =
111 TagMap $ IntMap.unionWithKey (g' combiner) m n
112 where
113 combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a
114 combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of
115 MyTagType_Single -> a
116 MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b
117 MyTagType_Multi2 -> case _multi2Contents_dict a of
118 Dict -> Multi2Contents
119 { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)
120 , _multi2Contents_dict = Dict
121 }
122 MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b
123 g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any
124 g' f rawKey a b =
125 let k = MyTag rawKey :: MyTag a
126 fromAny :: Any -> Entry f a
127 fromAny = unsafeCoerce
128 toAny :: Entry f a -> Any
129 toAny = unsafeCoerce
130 in toAny $ f k (fromAny a) (fromAny b)
132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
133requesterDataToList (RequesterData m) = do
134 k :=> Entry e <- tagMapToList m
135 case myKeyType k of
136 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
137 MyTagType_Multi -> do
138 (k', e') <- IntMap.toList e
139 k'' :=> e'' <- requesterDataToList e'
140 return $ RequesterDataKey_Multi k k' k'' :=> e''
141 MyTagType_Multi2 -> case _multi2Contents_dict e of
142 Dict -> do
143 (k', e') <- Map.toList $ _multi2Contents_values e
144 (k'', e'') <- IntMap.toList e'
145 k''' :=> e''' <- requesterDataToList e''
146 return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
147 MyTagType_Multi3 -> do
148 (k', e') <- IntMap.toList e
149 (k'', e'') <- IntMap.toList e'
150 k''' :=> e''' <- requesterDataToList e''
151 return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
153singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
154singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
156tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
157tagMapToList (TagMap m) = f <$> IntMap.toList m
158 where f :: (Int, Any) -> DSum MyTag f
159 f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
161traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
162traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
163 where
164 g :: Int -> Any -> t Any
165 g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
167-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
168traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
169traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
170 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
171 go k (Entry request) = Entry <$> case myKeyType k of
172 MyTagType_Single -> f request
173 MyTagType_Multi -> traverse (traverseRequesterData f) request
174 MyTagType_Multi2 -> case request of
175 Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do
176 v <- traverse (traverse (traverseRequesterData f)) request'
177 pure $ Multi2Contents
178 { _multi2Contents_values = v
179 , _multi2Contents_dict = Dict
180 }
181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
183-- | 'traverseRequesterData' with its arguments flipped
184forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
185forRequesterData r f = traverseRequesterData f r
187data MyTagType :: * -> * where
188 MyTagType_Single :: MyTagType (Single a)
189 MyTagType_Multi :: MyTagType Multi
190 MyTagType_Multi2 :: MyTagType (Multi2 k)
191 MyTagType_Multi3 :: MyTagType Multi3
193myKeyType :: MyTag x -> MyTagType x
194myKeyType (MyTag k) = case k .&. 0x3 of
195 0x0 -> unsafeCoerce MyTagType_Single
196 0x1 -> unsafeCoerce MyTagType_Multi
197 0x2 -> unsafeCoerce MyTagType_Multi2
198 0x3 -> unsafeCoerce MyTagType_Multi3
199 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
201data Single a
202data Multi
203data Multi2 (k :: * -> *)
204data Multi3
206class MyTagTypeOffset x where
207 myTagTypeOffset :: proxy x -> Int
209instance MyTagTypeOffset (Single a) where
210 myTagTypeOffset _ = 0x0
212instance MyTagTypeOffset Multi where
213 myTagTypeOffset _ = 0x1
215instance MyTagTypeOffset (Multi2 k) where
216 myTagTypeOffset _ = 0x2
218instance MyTagTypeOffset Multi3 where
219 myTagTypeOffset _ = 0x3
221type family EntryContents request a where
222 EntryContents request (Single a) = request a
223 EntryContents request Multi = IntMap (RequesterData request)
224 EntryContents request (Multi2 k) = Multi2Contents k request
225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
227data Multi2Contents k request = Multi2Contents
228 { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances
229 , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))
230 }
232newtype Entry request x = Entry { unEntry :: EntryContents request x }
234{-# INLINE singleEntry #-}
235singleEntry :: f a -> Entry f (Single a)
236singleEntry = Entry
238{-# INLINE multiEntry #-}
239multiEntry :: IntMap (RequesterData f) -> Entry f Multi
240multiEntry = Entry
242{-# INLINE unMultiEntry #-}
243unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
244unMultiEntry = unEntry
246-- | 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
247-- 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
248newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
250newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
252{-# INLINE castMyTagWrap #-}
253castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
254castMyTagWrap = coerce
256instance GEq MyTag where
257 (MyTag a) `geq` (MyTag b) =
258 if a == b
259 then Just $ unsafeCoerce Refl
260 else Nothing
262instance GCompare MyTag where
263 (MyTag a) `gcompare` (MyTag b) =
264 case a `compare` b of
265 LT -> GLT
266 EQ -> unsafeCoerce GEQ
267 GT -> GGT
269instance GEq (MyTagWrap f) where
270 (MyTagWrap a) `geq` (MyTagWrap b) =
271 if a == b
272 then Just $ unsafeCoerce Refl
273 else Nothing
275instance GCompare (MyTagWrap f) where
276 (MyTagWrap a) `gcompare` (MyTagWrap b) =
277 case a `compare` b of
278 LT -> GLT
279 EQ -> unsafeCoerce GEQ
280 GT -> GGT
282data RequesterState t (request :: * -> *) = RequesterState
283 { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
284 , _requesterState_requests :: ![(Int, Event t Any)]
285 }
287-- | A basic implementation of 'Requester'.
288newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
289 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
290-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
291#if MIN_VERSION_base(4,9,1)
292 , MonadAsyncException
293#endif
294 )
296deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
297deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
298deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
299deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
301instance PrimMonad m => PrimMonad (RequesterT t request response m) where
302 type PrimState (RequesterT t request response m) = PrimState m
303 primitive = lift . primitive
305-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
306instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
307 mempty = pure mempty
308 mappend = liftA2 mappend
310instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
311 (<>) = liftA2 (S.<>)
314-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
315-- requests are made, and responses should be provided in the input 'Event'.
316-- The 'Tag' keys will be used to return the responses to the same place the
317-- requests were issued.
318runRequesterT :: (Reflex t, Monad m)
319 => RequesterT t request response m a
320 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
321 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
322runRequesterT (RequesterT a) responses = do
323 (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
324 coerceEvent responses
325 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
327-- | Map a function over the request and response of a 'RequesterT'
328withRequesterT
329 :: (Reflex t, MonadFix m)
330 => (forall x. req x -> req' x) -- ^ The function to map over the request
331 -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response
332 -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed
333 -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'
334withRequesterT freq frsp child = do
335 rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'
336 (a, req) <- lift $ runRequesterT child rsp
337 rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $
338 fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req
339 return a
341instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
342 type Request (RequesterT t request response m) = request
343 type Response (RequesterT t request response m) = response
344 requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
345 requesting_ = void . tagRequest . fmapCheap singleEntry
347{-# INLINE tagRequest #-}
348tagRequest :: 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))
349tagRequest req = do
350 old <- RequesterT get
351 let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
352 t = MyTagWrap n
353 RequesterT $ put $ RequesterState
354 { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
355 , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
356 }
357 return t
359{-# INLINE responseFromTag #-}
360responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361responseFromTag (MyTagWrap t) = do
362 responses :: EventSelectorInt t Any <- RequesterT ask
363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
365instance MonadTrans (RequesterT t request response) where
366 lift = RequesterT . lift . lift
368instance MFunctor (RequesterT t request response) where
369 hoist f = RequesterT . hoist (hoist f) . unRequesterT
371instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
372 type Performable (RequesterT t request response m) = Performable m
373 performEvent_ = lift . performEvent_
374 performEvent = lift . performEvent
376instance MonadRef m => MonadRef (RequesterT t request response m) where
377 type Ref (RequesterT t request response m) = Ref m
378 newRef = lift . newRef
379 readRef = lift . readRef
380 writeRef r = lift . writeRef r
382instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
383 newEventWithTrigger = lift . newEventWithTrigger
384 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
386instance MonadReader r m => MonadReader r (RequesterT t request response m) where
387 ask = lift ask
388 local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
389 reader = lift . reader
391instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
392 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
393 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
394 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
395 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
396 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
398requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
399requesting' = responseFromTag . castMyTagWrap <=< tagRequest
401{-# INLINABLE runWithReplaceRequesterTWith #-}
402runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
403 , MonadFix m
404 )
405 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
406 -> RequesterT t request response m a
407 -> Event t (RequesterT t request response m b)
408 -> RequesterT t request response m (a, Event t b)
409runWithReplaceRequesterTWith f a0 a' = do
410 rec na' <- numberOccurrencesFrom 1 a'
411 responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
412 let responses' = fanInt responses
413 ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
414 requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
415 return (result0, fmapCheap (fst . snd) v')
417{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
418traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
419 ( Reflex t
420 , MonadHold t m
421 , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
422 , Patch (p (Event t (IntMap (RequesterData request))))
423 , Functor p
424 , MonadFix m
425 )
426 => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
427 -> IntMap (IntMap.Key, v)
428 -> Event t (p (IntMap.Key, v))
429 -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
430 )
431 -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
432 -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
433 -> (IntMap.Key -> v -> RequesterT t request response m v')
434 -> IntMap v
435 -> Event t (p v)
436 -> RequesterT t request response m (IntMap v', Event t (p v'))
437traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
438 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
439 let responses :: EventSelectorInt t (IntMap (RequesterData response))
440 responses = fanInt $ fmapCheap unpack response
441 unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
442 unpack = unEntry
443 pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
444 pack = Entry
445 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
446 f' k (n, v) = do
447 (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?
448 return (fmapCheap (IntMap.singleton n) myRequests, result)
449 ndm' <- numberOccurrencesFrom 1 dm'
450 (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
451 let result0 = fmap snd children0
452 result' = fforCheap children' $ fmap snd
453 requests0 :: IntMap (Event t (IntMap (RequesterData request)))
454 requests0 = fmap fst children0
455 requests' :: Event t (p (Event t (IntMap (RequesterData request))))
456 requests' = fforCheap children' $ fmap fst
457 promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
458 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
459 requests <- holdIncremental requests0 requests'
460 return (result0, result')
462{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
463traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
464 ( GCompare k
465 , Reflex t
466 , MonadHold t m
467 , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
468 , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
469 , MonadFix m
470 )
471 => (forall k' v1 v2. GCompare k'
472 => (forall a. k' a -> v1 a -> m (v2 a))
473 -> DMap k' v1
474 -> Event t (p k' v1)
475 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
476 )
477 -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
478 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
479 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
480 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
481 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
482 -> DMap k v
483 -> Event t (p k v)
484 -> RequesterT t request response m (DMap k v', Event t (p k v'))
485traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
486 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
488 responses = fanMap $ fmapCheap unpack response
489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
490 unpack = _multi2Contents_values . unEntry
491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
492 pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
494 f' k (Compose (n, v)) = do
495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
496 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
497 ndm' <- numberOccurrencesFrom 1 dm'
498 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
499 let result0 = DMap.map (snd . getCompose) children0
500 result' = fforCheap children' $ mapPatch $ snd . getCompose
501 requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
502 requests0 = weakenDMapWith (fst . getCompose) children0
503 requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
504 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
505 promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
506 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
507 requests <- holdIncremental requests0 requests'
508 return (result0, result')
510data Decoder rawResponse response =
511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
513matchResponsesWithRequests
514 :: forall t rawRequest rawResponse request response m.
515 ( MonadFix m
516 , MonadHold t m
517 , Reflex t
518 )
519 => (forall a. request a -> (rawRequest, rawResponse -> response a))
520 -- ^ Given a request (from 'Requester'), produces the wire format of the
521 -- request and a function used to process the associated response
522 -> Event t (RequesterData request)
523 -- ^ The outgoing requests
524 -> Event t (Int, rawResponse)
525 -- ^ The incoming responses, tagged by an identifying key
526 -> m ( Event t (Map Int rawRequest)
527 , Event t (RequesterData response)
528 )
529 -- ^ A map of outgoing wire-format requests and an event of responses keyed
530 -- by the 'RequesterData' key of the associated outgoing request
531matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv
533-- | Matches incoming responses with previously-sent requests
534-- and uses the provided request "decoder" function to process
535-- incoming responses.
536matchResponseMapWithRequests
537 :: forall t rawRequest rawResponse request response m.
538 ( MonadFix m
539 , MonadHold t m
540 , Reflex t
541 )
542 => (forall a. request a -> (rawRequest, rawResponse -> response a))
543 -- ^ Given a request (from 'Requester'), produces the wire format of the
544 -- request and a function used to process the associated response
545 -> Event t (RequesterData request)
546 -- ^ The outgoing requests
547 -> Event t (Map Int rawResponse)
548 -- ^ A map of incoming responses, tagged by an identifying key
549 -> m ( Event t (Map Int rawRequest)
550 , Event t (RequesterData response)
551 )
552 -- ^ A map of outgoing wire-format requests and an event of responses keyed
553 -- by the 'RequesterData' key of the associated outgoing request
554matchResponseMapWithRequests f send recv = do
555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
557 holdIncremental mempty $ leftmost
558 [ fmap (\(_, outstanding, _) -> outstanding) outgoing
559 , snd <$> incoming
560 ]
561 let outgoing = processOutgoing nextId send
562 incoming = processIncoming waitingFor recv
563 return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
564 where
565 -- Tags each outgoing request with an identifying integer key
566 -- and returns the next available key, a map of response decoders
567 -- for requests for which there are outstanding responses, and the
568 -- raw requests to be sent out.
569 processOutgoing
570 :: Behavior t Int
571 -- The next available key
572 -> Event t (RequesterData request)
573 -- The outgoing request
574 -> Event t ( Int
575 , PatchMap Int (Decoder rawResponse response)
576 , Map Int rawRequest )
577 -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
578 processOutgoing nextId out = flip pushAlways out $ \dm -> do
579 oldNextId <- sample nextId
580 let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
581 n <- get
582 put $ succ n
583 let (rawReq, rspF) = f v
584 return (n, rawReq, Decoder k rspF)
585 patchWaitingFor = PatchMap $ Map.fromList $
586 (\(n, _, dec) -> (n, Just dec)) <$> result
587 toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
588 return (newNextId, patchWaitingFor, toSend)
589 -- Looks up the each incoming raw response in a map of response
590 -- decoders and returns the decoded response and a patch that can
591 -- be used to clear the ID of the consumed response out of the queue
592 -- of expected responses.
593 processIncoming
594 :: Incremental t (PatchMap Int (Decoder rawResponse response))
595 -- A map of outstanding expected responses
596 -> Event t (Map Int rawResponse)
597 -- A incoming response paired with its identifying key
598 -> Event t (RequesterData response, PatchMap Int v)
599 -- The decoded response and a patch that clears the outstanding responses queue
600 processIncoming waitingFor inc = flip push inc $ \rspMap -> do
601 wf <- sample $ currentIncremental waitingFor
602 let match rawRsp (Decoder k rspF) =
603 let rsp = rspF rawRsp
604 in singletonRequesterData k rsp
605 matches = Map.intersectionWith match rspMap wf
606 pure $ if Map.null matches then Nothing else Just
607 (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)