@@ -1,607 +1,23 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- '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
223module Reflex.Requester.Base
234 ( RequesterT (..)
5+ , RequestData (..)
6+ , ResponseData (..)
7+ , RequestEnvelope (..)
248 , runRequesterT
25− , withRequesterT
26− , runWithReplaceRequesterTWith
27− , traverseIntMapWithKeyWithAdjustRequesterTWith
28− , traverseDMapWithKeyWithAdjustRequesterTWith
29− , RequesterData
30− , RequesterDataKey
9+-- , withRequesterT
10+-- , RequesterData
11+-- , RequesterDataKey
3112 , traverseRequesterData
3213 , forRequesterData
33− , requesterDataToList
34− , singletonRequesterData
14+ , requestEnvelopesToDSums
15+ , singletonRequestData
16+ , singletonResponseData
3517 , matchResponsesWithRequests
36− , matchResponseMapWithRequests
37− , multiEntry
38− , unMultiEntry
39− , requesting'
18+-- , multiEntry
19+-- , unMultiEntry
20+-- , requesting'
4021 ) where
4122
42−import Reflex.Class
43−import Reflex.Adjustable.Class
44−import Reflex.Dynamic
45−import Reflex.Host.Class
46−import Reflex.PerformEvent.Class
47−import Reflex.PostBuild.Class
48−import Reflex.Requester.Class
49−import Reflex.TriggerEvent.Class
50−
51−import Control.Applicative (liftA2)
52−import Control.Monad.Exception
53−import Control.Monad.Identity
54−import Control.Monad.Morph
55−import Control.Monad.Primitive
56−import Control.Monad.Reader
57−import Control.Monad.Ref
58−import Control.Monad.State.Strict
59−import Data.Bits
60−import Data.Coerce
61−import Data.Constraint
62−import Data.Dependent.Map (DMap)
63−import qualified Data.Dependent.Map as DMap
64−import Data.Dependent.Sum (DSum (..))
65−import Data.Functor.Compose
66−import Data.Functor.Misc
67−import Data.IntMap.Strict (IntMap)
68−import qualified Data.IntMap.Strict as IntMap
69−import Data.Map (Map)
70−import qualified Data.Map as Map
71−import Data.Monoid ((<>))
72−import Data.Proxy
73−import qualified Data.Semigroup as S
74−import Data.Some (Some(Some))
75−import Data.Type.Equality
76−import Data.Unique.Tag
77−
78−import GHC.Exts (Any)
79−import Unsafe.Coerce
80−
81−--TODO: Make this module type-safe
82−
83−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
84−
85−newtype RequesterData f = RequesterData (TagMap (Entry f))
86−
87−emptyRequesterData :: RequesterData f
88−emptyRequesterData = RequesterData $ TagMap IntMap.empty
89−
90−data 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
95−
96−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
97−singletonRequesterData 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
105−
106−mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f
107−mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b
108−
109−mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)
110−mergeTagMap (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)
131−
132−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
133−requesterDataToList (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'''
152−
153−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
154−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
155−
156−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
157−tagMapToList (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
160−
161−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
162−traverseTagMapWithKey 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)
166−
167−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
168−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
169−traverseRequesterData 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
182−
183−-- | 'traverseRequesterData' with its arguments flipped
184−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
185−forRequesterData r f = traverseRequesterData f r
186−
187−data MyTagType :: * -> * where
188− MyTagType_Single :: MyTagType (Single a)
189− MyTagType_Multi :: MyTagType Multi
190− MyTagType_Multi2 :: MyTagType (Multi2 k)
191− MyTagType_Multi3 :: MyTagType Multi3
192−
193−myKeyType :: MyTag x -> MyTagType x
194−myKeyType (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
200−
201−data Single a
202−data Multi
203−data Multi2 (k :: * -> *)
204−data Multi3
205−
206−class MyTagTypeOffset x where
207− myTagTypeOffset :: proxy x -> Int
208−
209−instance MyTagTypeOffset (Single a) where
210− myTagTypeOffset _ = 0x0
211−
212−instance MyTagTypeOffset Multi where
213− myTagTypeOffset _ = 0x1
214−
215−instance MyTagTypeOffset (Multi2 k) where
216− myTagTypeOffset _ = 0x2
217−
218−instance MyTagTypeOffset Multi3 where
219− myTagTypeOffset _ = 0x3
220−
221−type 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))
226−
227−data 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− }
231−
232−newtype Entry request x = Entry { unEntry :: EntryContents request x }
233−
234−{-# INLINE singleEntry #-}
235−singleEntry :: f a -> Entry f (Single a)
236−singleEntry = Entry
237−
238−{-# INLINE multiEntry #-}
239−multiEntry :: IntMap (RequesterData f) -> Entry f Multi
240−multiEntry = Entry
241−
242−{-# INLINE unMultiEntry #-}
243−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
244−unMultiEntry = unEntry
245−
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
248−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
249−
250−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
251−
252−{-# INLINE castMyTagWrap #-}
253−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
254−castMyTagWrap = coerce
255−
256−instance GEq MyTag where
257− (MyTag a) `geq` (MyTag b) =
258− if a == b
259− then Just $ unsafeCoerce Refl
260− else Nothing
261−
262−instance 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
268−
269−instance GEq (MyTagWrap f) where
270− (MyTagWrap a) `geq` (MyTagWrap b) =
271− if a == b
272− then Just $ unsafeCoerce Refl
273− else Nothing
274−
275−instance 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
281−
282−data 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− }
286−
287−-- | A basic implementation of 'Requester'.
288−newtype 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− )
295−
296−deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
297−deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
298−deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
299−deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
300−
301−instance PrimMonad m => PrimMonad (RequesterT t request response m) where
302− type PrimState (RequesterT t request response m) = PrimState m
303− primitive = lift . primitive
304−
305−-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
306−instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
307− mempty = pure mempty
308− mappend = liftA2 mappend
309−
310−instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
311− (<>) = liftA2 (S.<>)
312−
313−
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.
318−runRequesterT :: (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
322−runRequesterT (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)
326−
327−-- | Map a function over the request and response of a 'RequesterT'
328−withRequesterT
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'
334−withRequesterT 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
340−
341−instance (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
346−
347−{-# INLINE tagRequest #-}
348−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))
349−tagRequest 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
358−
359−{-# INLINE responseFromTag #-}
360−responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361−responseFromTag (MyTagWrap t) = do
362− responses :: EventSelectorInt t Any <- RequesterT ask
363− return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
364−
365−instance MonadTrans (RequesterT t request response) where
366− lift = RequesterT . lift . lift
367−
368−instance MFunctor (RequesterT t request response) where
369− hoist f = RequesterT . hoist (hoist f) . unRequesterT
370−
371−instance 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
375−
376−instance 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
381−
382−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
383− newEventWithTrigger = lift . newEventWithTrigger
384− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
385−
386−instance 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
390−
391−instance (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
397−
398−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
399−requesting' = responseFromTag . castMyTagWrap <=< tagRequest
400−
401−{-# INLINABLE runWithReplaceRequesterTWith #-}
402−runWithReplaceRequesterTWith :: 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)
409−runWithReplaceRequesterTWith 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')
416−
417−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
418−traverseIntMapWithKeyWithAdjustRequesterTWith :: 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'))
437−traverseIntMapWithKeyWithAdjustRequesterTWith 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')
461−
462−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
463−traverseDMapWithKeyWithAdjustRequesterTWith :: 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'))
485−traverseDMapWithKeyWithAdjustRequesterTWith 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')
509−
510−data Decoder rawResponse response =
511− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
512−
513−matchResponsesWithRequests
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
531−matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv
532−
533−-- | Matches incoming responses with previously-sent requests
534−-- and uses the provided request "decoder" function to process
535−-- incoming responses.
536−matchResponseMapWithRequests
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
554−matchResponseMapWithRequests 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)
23+import Reflex.Requester.Base.Internal