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