@@ -1,537 +1,23 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- '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
213module Reflex.Requester.Base
224 ( RequesterT (..)
5+ , RequestData (..)
6+ , ResponseData (..)
7+ , RequestEnvelope (..)
238 , runRequesterT
24− , withRequesterT
25− , runWithReplaceRequesterTWith
26− , traverseIntMapWithKeyWithAdjustRequesterTWith
27− , traverseDMapWithKeyWithAdjustRequesterTWith
28− , RequesterData
29− , RequesterDataKey
9+-- , withRequesterT
10+-- , RequesterData
11+-- , RequesterDataKey
3012 , traverseRequesterData
3113 , forRequesterData
32− , requesterDataToList
33− , singletonRequesterData
14+ , requestEnvelopesToDSums
15+ , singletonRequestData
16+ , singletonResponseData
3417 , matchResponsesWithRequests
35− , multiEntry
36− , unMultiEntry
37− , requesting'
18+-- , multiEntry
19+-- , unMultiEntry
20+-- , requesting'
3821 ) where
3922
40−import Reflex.Class
41−import Reflex.Adjustable.Class
42−import Reflex.Dynamic
43−import Reflex.Host.Class
44−import Reflex.PerformEvent.Class
45−import Reflex.PostBuild.Class
46−import Reflex.Requester.Class
47−import Reflex.TriggerEvent.Class
48−
49−import Control.Applicative (liftA2)
50−import Control.Monad.Exception
51−import Control.Monad.Identity
52−import Control.Monad.Primitive
53−import Control.Monad.Reader
54−import Control.Monad.Ref
55−import Control.Monad.State.Strict
56−import Data.Bits
57−import Data.Coerce
58−import Data.Dependent.Map (DMap, DSum (..))
59−import qualified Data.Dependent.Map as DMap
60−import Data.Functor.Compose
61−import Data.Functor.Misc
62−import Data.IntMap.Strict (IntMap)
63−import qualified Data.IntMap.Strict as IntMap
64−import Data.Map (Map)
65−import qualified Data.Map as Map
66−import Data.Monoid ((<>))
67−import Data.Proxy
68−import qualified Data.Semigroup as S
69−import Data.Some (Some(Some))
70−import Data.Type.Equality
71−import Data.Unique.Tag
72−
73−import GHC.Exts (Any)
74−import Unsafe.Coerce
75−
76−--TODO: Make this module type-safe
77−
78−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
79−
80−newtype RequesterData f = RequesterData (TagMap (Entry f))
81−
82−data 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
87−
88−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
89−singletonRequesterData 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
94−
95−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
96−requesterDataToList (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'''
114−
115−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
116−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
117−
118−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
119−tagMapToList (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
122−
123−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
124−traverseTagMapWithKey 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)
128−
129−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
130−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
131−traverseRequesterData 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
138−
139−-- | 'traverseRequesterData' with its arguments flipped
140−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
141−forRequesterData r f = traverseRequesterData f r
142−
143−data MyTagType :: * -> * where
144− MyTagType_Single :: MyTagType (Single a)
145− MyTagType_Multi :: MyTagType Multi
146− MyTagType_Multi2 :: MyTagType (Multi2 k)
147− MyTagType_Multi3 :: MyTagType Multi3
148−
149−myKeyType :: MyTag x -> MyTagType x
150−myKeyType (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
156−
157−data Single a
158−data Multi
159−data Multi2 (k :: * -> *)
160−data Multi3
161−
162−class MyTagTypeOffset x where
163− myTagTypeOffset :: proxy x -> Int
164−
165−instance MyTagTypeOffset (Single a) where
166− myTagTypeOffset _ = 0x0
167−
168−instance MyTagTypeOffset Multi where
169− myTagTypeOffset _ = 0x1
170−
171−instance MyTagTypeOffset (Multi2 k) where
172− myTagTypeOffset _ = 0x2
173−
174−instance MyTagTypeOffset Multi3 where
175− myTagTypeOffset _ = 0x3
176−
177−type 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))
182−
183−newtype Entry request x = Entry { unEntry :: EntryContents request x }
184−
185−{-# INLINE singleEntry #-}
186−singleEntry :: f a -> Entry f (Single a)
187−singleEntry = Entry
188−
189−{-# INLINE multiEntry #-}
190−multiEntry :: IntMap (RequesterData f) -> Entry f Multi
191−multiEntry = Entry
192−
193−{-# INLINE unMultiEntry #-}
194−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
195−unMultiEntry = unEntry
196−
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
199−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
200−
201−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
202−
203−{-# INLINE castMyTagWrap #-}
204−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
205−castMyTagWrap = coerce
206−
207−instance GEq MyTag where
208− (MyTag a) `geq` (MyTag b) =
209− if a == b
210− then Just $ unsafeCoerce Refl
211− else Nothing
212−
213−instance 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
219−
220−instance GEq (MyTagWrap f) where
221− (MyTagWrap a) `geq` (MyTagWrap b) =
222− if a == b
223− then Just $ unsafeCoerce Refl
224− else Nothing
225−
226−instance 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
232−
233−data 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− }
237−
238−-- | A basic implementation of 'Requester'.
239−newtype 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− )
246−
247−deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
248−deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
249−deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
250−deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
251−
252−instance PrimMonad m => PrimMonad (RequesterT t request response m) where
253− type PrimState (RequesterT t request response m) = PrimState m
254− primitive = lift . primitive
255−
256−-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
257−instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
258− mempty = pure mempty
259− mappend = liftA2 mappend
260−
261−instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
262− (<>) = liftA2 (S.<>)
263−
264−
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.
269−runRequesterT :: (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
273−runRequesterT (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)
277−
278−-- | Map a function over the request and response of a 'RequesterT'
279−withRequesterT
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'
285−withRequesterT 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
291−
292−instance (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
297−
298−{-# INLINE tagRequest #-}
299−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))
300−tagRequest 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
309−
310−{-# INLINE responseFromTag #-}
311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
312−responseFromTag (MyTagWrap t) = do
313− responses :: EventSelectorInt t Any <- RequesterT ask
314− return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
315−
316−instance MonadTrans (RequesterT t request response) where
317− lift = RequesterT . lift . lift
318−
319−instance 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
323−
324−instance 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
329−
330−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
331− newEventWithTrigger = lift . newEventWithTrigger
332− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
333−
334−instance 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
338−
339−instance (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
345−
346−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
347−requesting' = responseFromTag . castMyTagWrap <=< tagRequest
348−
349−{-# INLINABLE runWithReplaceRequesterTWith #-}
350−runWithReplaceRequesterTWith :: 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)
357−runWithReplaceRequesterTWith 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')
364−
365−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
366−traverseIntMapWithKeyWithAdjustRequesterTWith :: 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'))
385−traverseIntMapWithKeyWithAdjustRequesterTWith 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')
409−
410−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
411−traverseDMapWithKeyWithAdjustRequesterTWith :: 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'))
433−traverseDMapWithKeyWithAdjustRequesterTWith 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')
457−
458−data Decoder rawResponse response =
459− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
460−
461−-- | Matches incoming responses with previously-sent requests
462−-- and uses the provided request "decoder" function to process
463−-- incoming responses.
464−matchResponsesWithRequests
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
482−matchResponsesWithRequests 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− )
23+import Reflex.Requester.Base.Internal