@@ -1,7 +1,6 @@
1-- | This module provides 'RequesterT', the standard implementation of
1-- | This module provides 'RequesterT', the standard implementation of
2-- 'Requester'.
2-- 'Requester'.
3{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ApplicativeDo #-}
5{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
6{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE ExistentialQuantification #-}
@@ -33,7 +32,6 @@ module Reflex.Requester.Base
33 , requesterDataToList
32 , requesterDataToList
34 , singletonRequesterData
33 , singletonRequesterData
35 , matchResponsesWithRequests
34 , matchResponsesWithRequests
36− , matchResponseMapWithRequests
37 , multiEntry
35 , multiEntry
38 , unMultiEntry
36 , unMultiEntry
39 , requesting'
37 , requesting'
@@ -51,14 +49,12 @@ import Reflex.TriggerEvent.Class
51import Control.Applicative (liftA2)
49import Control.Applicative (liftA2)
52import Control.Monad.Exception
50import Control.Monad.Exception
53import Control.Monad.Identity
51import Control.Monad.Identity
54−import Control.Monad.Morph
55import Control.Monad.Primitive
52import Control.Monad.Primitive
56import Control.Monad.Reader
53import Control.Monad.Reader
57import Control.Monad.Ref
54import Control.Monad.Ref
58import Control.Monad.State.Strict
55import Control.Monad.State.Strict
59import Data.Bits
56import Data.Bits
60import Data.Coerce
57import Data.Coerce
61−import Data.Constraint
62import Data.Dependent.Map (DMap)
58import Data.Dependent.Map (DMap)
63import qualified Data.Dependent.Map as DMap
59import qualified Data.Dependent.Map as DMap
64import Data.Dependent.Sum (DSum (..))
60import Data.Dependent.Sum (DSum (..))
@@ -84,51 +80,19 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
85newtype RequesterData f = RequesterData (TagMap (Entry f))
81newtype RequesterData f = RequesterData (TagMap (Entry f))
87−emptyRequesterData :: RequesterData f
88−emptyRequesterData = RequesterData $ TagMap IntMap.empty
90data RequesterDataKey a where
83data RequesterDataKey a where
91 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
84 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
85 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead
93− RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
86+ RequesterDataKey_Multi2 :: {-# 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
87 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
89singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
97singletonRequesterData rdk v = case rdk of
90singletonRequesterData rdk v = case rdk of
98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
91 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
99 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
92 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
93+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
101− { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
102− , _multi2Contents_dict = Dict
104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
94 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
106−mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f
107−mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b
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
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
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
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]
96requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
133requesterDataToList (RequesterData m) = do
97requesterDataToList (RequesterData m) = do
134 k :=> Entry e <- tagMapToList m
98 k :=> Entry e <- tagMapToList m
@@ -138,12 +102,11 @@ requesterDataToList (RequesterData m) = do
138 (k', e') <- IntMap.toList e
102 (k', e') <- IntMap.toList e
139 k'' :=> e'' <- requesterDataToList e'
103 k'' :=> e'' <- requesterDataToList e'
140 return $ RequesterDataKey_Multi k k' k'' :=> e''
104 return $ RequesterDataKey_Multi k k' k'' :=> e''
141− MyTagType_Multi2 -> case _multi2Contents_dict e of
105+ MyTagType_Multi2 -> do
143− (k', e') <- Map.toList $ _multi2Contents_values e
106+ (k', e') <- Map.toList e
144− (k'', e'') <- IntMap.toList e'
107+ (k'', e'') <- IntMap.toList e'
145− k''' :=> e''' <- requesterDataToList e''
108+ k''' :=> e''' <- requesterDataToList e''
146− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
109+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
147 MyTagType_Multi3 -> do
110 MyTagType_Multi3 -> do
148 (k', e') <- IntMap.toList e
111 (k', e') <- IntMap.toList e
149 (k'', e'') <- IntMap.toList e'
112 (k'', e'') <- IntMap.toList e'
@@ -171,13 +134,7 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
171 go k (Entry request) = Entry <$> case myKeyType k of
134 go k (Entry request) = Entry <$> case myKeyType k of
172 MyTagType_Single -> f request
135 MyTagType_Single -> f request
173 MyTagType_Multi -> traverse (traverseRequesterData f) request
136 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'
137+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
177− pure $ Multi2Contents
178− { _multi2Contents_values = v
179− , _multi2Contents_dict = Dict
181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
138 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
183-- | 'traverseRequesterData' with its arguments flipped
140-- | 'traverseRequesterData' with its arguments flipped
@@ -221,14 +178,9 @@ instance MyTagTypeOffset Multi3 where
221type family EntryContents request a where
178type family EntryContents request a where
222 EntryContents request (Single a) = request a
179 EntryContents request (Single a) = request a
223 EntryContents request Multi = IntMap (RequesterData request)
180 EntryContents request Multi = IntMap (RequesterData request)
224− EntryContents request (Multi2 k) = Multi2Contents k request
181+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
182 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
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)))
232newtype Entry request x = Entry { unEntry :: EntryContents request x }
184newtype Entry request x = Entry { unEntry :: EntryContents request x }
234{-# INLINE singleEntry #-}
186{-# INLINE singleEntry #-}
@@ -357,7 +309,7 @@ tagRequest req = do
359{-# INLINE responseFromTag #-}
311{-# 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))
312+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361responseFromTag (MyTagWrap t) = do
313responseFromTag (MyTagWrap t) = do
362 responses :: EventSelectorInt t Any <- RequesterT ask
314 responses :: EventSelectorInt t Any <- RequesterT ask
363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
315 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
@@ -365,9 +317,6 @@ responseFromTag (MyTagWrap t) = do
365instance MonadTrans (RequesterT t request response) where
317instance MonadTrans (RequesterT t request response) where
366 lift = RequesterT . lift . lift
318 lift = RequesterT . lift . lift
368−instance 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
320instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
372 type Performable (RequesterT t request response m) = Performable m
321 type Performable (RequesterT t request response m) = Performable m
373 performEvent_ = lift . performEvent_
322 performEvent_ = lift . performEvent_
@@ -487,9 +436,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
436 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
488 responses = fanMap $ fmapCheap unpack response
437 responses = fanMap $ fmapCheap unpack response
489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
438 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
490− unpack = _multi2Contents_values . unEntry
439+ unpack = unEntry
491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
440 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
492− pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
441+ pack = Entry
493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
442 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
443 f' k (Compose (n, v)) = do
495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
444 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
@@ -510,30 +459,10 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
510data Decoder rawResponse response =
459data Decoder rawResponse response =
511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
460 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
513−matchResponsesWithRequests
514− :: forall t rawRequest rawResponse request response m.
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)
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
533-- | Matches incoming responses with previously-sent requests
462-- | Matches incoming responses with previously-sent requests
534-- and uses the provided request "decoder" function to process
463-- and uses the provided request "decoder" function to process
535-- incoming responses.
464-- incoming responses.
536−matchResponseMapWithRequests
465+matchResponsesWithRequests
537 :: forall t rawRequest rawResponse request response m.
466 :: forall t rawRequest rawResponse request response m.
538 ( MonadFix m
467 ( MonadFix m
539 , MonadHold t m
468 , MonadHold t m
@@ -544,14 +473,14 @@ matchResponseMapWithRequests
544 -- request and a function used to process the associated response
473 -- request and a function used to process the associated response
545 -> Event t (RequesterData request)
474 -> Event t (RequesterData request)
546 -- ^ The outgoing requests
475 -- ^ The outgoing requests
547− -> Event t (Map Int rawResponse)
476+ -> Event t (Int, rawResponse)
548− -- ^ A map of incoming responses, tagged by an identifying key
477+ -- ^ The incoming responses, tagged by an identifying key
549 -> m ( Event t (Map Int rawRequest)
478 -> m ( Event t (Map Int rawRequest)
550 , Event t (RequesterData response)
479 , Event t (RequesterData response)
552 -- ^ A map of outgoing wire-format requests and an event of responses keyed
481 -- ^ A map of outgoing wire-format requests and an event of responses keyed
553 -- by the 'RequesterData' key of the associated outgoing request
482 -- by the 'RequesterData' key of the associated outgoing request
554−matchResponseMapWithRequests f send recv = do
483+matchResponsesWithRequests f send recv = do
555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
484 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
485 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
557 holdIncremental mempty $ leftmost
486 holdIncremental mempty $ leftmost
@@ -593,15 +522,17 @@ matchResponseMapWithRequests f send recv = do
593 processIncoming
522 processIncoming
594 :: Incremental t (PatchMap Int (Decoder rawResponse response))
523 :: Incremental t (PatchMap Int (Decoder rawResponse response))
595 -- A map of outstanding expected responses
524 -- A map of outstanding expected responses
596− -> Event t (Map Int rawResponse)
525+ -> Event t (Int, rawResponse)
597 -- A incoming response paired with its identifying key
526 -- A incoming response paired with its identifying key
598 -> Event t (RequesterData response, PatchMap Int v)
527 -> Event t (RequesterData response, PatchMap Int v)
599 -- The decoded response and a patch that clears the outstanding responses queue
528 -- The decoded response and a patch that clears the outstanding responses queue
600− processIncoming waitingFor inc = flip push inc $ \rspMap -> do
529+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
601 wf <- sample $ currentIncremental waitingFor
530 wf <- sample $ currentIncremental waitingFor
602− let match rawRsp (Decoder k rspF) =
531+ case Map.lookup n wf of
603− let rsp = rspF rawRsp
532+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
604− in singletonRequesterData k rsp
533+ Just (Decoder k rspF) -> do
605− matches = Map.intersectionWith match rspMap wf
534+ let rsp = rspF rawRsp
606− pure $ if Map.null matches then Nothing else Just
535+ return $ Just
607− (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
536+ ( singletonRequesterData k rsp
537+ , PatchMap $ Map.singleton n Nothing