@@ -10,6 +10,7 @@
1010{-# LANGUAGE RecursiveDo #-}
1111{-# LANGUAGE ScopedTypeVariables #-}
1212{-# LANGUAGE StandaloneDeriving #-}
13+{-# LANGUAGE TypeApplications #-}
1314{-# LANGUAGE TypeFamilies #-}
1415{-# LANGUAGE TypeOperators #-}
1516{-# LANGUAGE UndecidableInstances #-}
@@ -31,10 +32,12 @@ import Reflex.EventWriter.Class
3132
3233import Control.Applicative (liftA2)
3334import Control.Monad.Exception
35+import Control.Monad.Fail
3436import Control.Monad.Identity
3537import Control.Monad.Primitive
3638import Control.Monad.Reader
3739import Control.Monad.Ref
40+import Control.Monad.State
3841import Data.Coerce
3942import Data.Dependent.Map (DSum (..))
4043import qualified Data.List.NonEmpty as NonEmpty
@@ -55,7 +58,15 @@ import Unsafe.Coerce
5558
5659import Debug.Trace
5760
61+import Data.Map (Map)
62+import qualified Data.Map as Map
63+import qualified Data.IntMap as IntMap
64+import GHC.Exts (Any)
65+
5866data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))
67+
68+data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
69+
5970data ResponseData ps response = forall s. ResponseData !(TagGen ps s) !(TagMap s response)
6071
6172traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequestData (PrimState m) request -> m (ResponseData (PrimState m) response)
@@ -110,8 +121,6 @@ withRequesterInternalT f = do
110121 ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses, tg)
111122 pure result
112123
113−data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
114−
115124-- This is because using forall ruins inlining
116125data FakeRequesterStatePhantom
117126
@@ -210,3 +219,159 @@ instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterT t request r
210219 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'
211220 {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}
212221 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'
222+
223+
224+data Decoder rawResponse response ps =
225+ forall a. Decoder (TagGen ps a) (rawResponse -> response a)
226+
227+-- | Matches incoming responses with previously-sent requests
228+-- and uses the provided request "decoder" function to process
229+-- incoming responses.
230+matchResponsesWithRequests
231+ :: forall t rawRequest rawResponse request response m.
232+ ( MonadFix m
233+ , MonadHold t m
234+ , MonadFail m
235+ , PrimMonad m
236+ , Reflex t
237+ )
238+ => (forall a. request a -> (rawRequest, rawResponse -> response a))
239+ -- ^ Given a request (from 'Requester'), produces the wire format of the
240+ -- request and a function used to process the associated response
241+ -> Event t (RequestData (PrimState m) request)
242+ -- ^ The outgoing requests
243+ -> Event t (Int, rawResponse)
244+ -- ^ The incoming responses, tagged by an identifying key
245+ -> m ( Event t (Map Int rawRequest)
246+ , Event t (ResponseData (PrimState m) response)
247+ )
248+ -- ^ A map of outgoing wire-format requests and an event of responses keyed
249+ -- by the 'RequesterData' key of the associated outgoing request
250+matchResponsesWithRequests f send recv = mdo
251+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response (PrimState m))) <- holdIncremental mempty $
252+ leftmost [ fst <$> outgoing, snd <$> incoming ]
253+ let outgoing = processOutgoing send
254+ incoming = processIncoming waitingFor recv
255+ return (snd <$> outgoing, fst <$> incoming)
256+ where
257+
258+ -- Tags each outgoing request with an identifying integer key
259+ -- and returns the next available key, a map of response decoders
260+ -- for requests for which there are outstanding responses, and the
261+ -- raw requests to be sent out.
262+
263+ {--
264+
265+ src/Reflex/Requester/Base/Internal.hs:271:53-67: error:
266+ • Couldn't match type ‘a’ with ‘s’
267+ ‘a’ is a rigid type variable bound by
268+ a pattern with constructor:
269+ :=> :: forall k (tag :: k -> *) (f :: k -> *) (a :: k).
270+ tag a -> f a -> DSum tag f,
271+ in a lambda abstraction
272+ at src/Reflex/Requester/Base/Internal.hs:269:98-104
273+ ‘s’ is a rigid type variable bound by
274+ a pattern with constructor:
275+ RequestData :: forall ps (request :: * -> *) s.
276+ TagGen ps s
277+ -> NonEmptyDeferred (RequestEnvelope s request)
278+ -> RequestData ps request,
279+ in a lambda abstraction
280+ at src/Reflex/Requester/Base/Internal.hs:268:85-119
281+ Expected type: rawResponse -> response s
282+ Actual type: rawResponse -> response a
283+ • In the second argument of ‘Decoder’, namely ‘responseDecoder’
284+ In the expression: Decoder tagGen responseDecoder
285+ In the expression:
286+ (tagId k, rawRequest, Decoder tagGen responseDecoder)
287+ • Relevant bindings include
288+ responseDecoder :: rawResponse -> response a
289+ (bound at src/Reflex/Requester/Base/Internal.hs:270:30)
290+ v :: request a
291+ (bound at src/Reflex/Requester/Base/Internal.hs:269:104)
292+ k :: Tag s a
293+ (bound at src/Reflex/Requester/Base/Internal.hs:269:98)
294+ requestEnvelopes :: NonEmptyDeferred (RequestEnvelope s request)
295+ (bound at src/Reflex/Requester/Base/Internal.hs:268:104)
296+ tagGen :: TagGen (PrimState m) s
297+ (bound at src/Reflex/Requester/Base/Internal.hs:268:97)
298+ |
299+271 | in (tagId k, rawRequest, Decoder tagGen
300+responseDecoder)
301+ |
302+^^^^^^^^^^^^^^^
303+ --}
304+ processOutgoing
305+ :: Event t (RequestData (PrimState m) request)
306+ -- The outgoing request
307+ -> Event t ( PatchMap Int (Decoder rawResponse response (PrimState m))
308+ , Map Int rawRequest )
309+ -- A map of requests expecting responses, and the tagged raw requests
310+ processOutgoing eventOutgoingRequest = flip pushAlways eventOutgoingRequest $ \(RequestData tagGen requestEnvelopes) -> do
311+ let results = ffor (requestEnvelopesToList $ NonEmptyDeferred.toList requestEnvelopes) $ \(k :=> v) ->
312+ let (rawRequest, responseDecoder) = f v
313+ in (tagId k, rawRequest, Decoder tagGen responseDecoder)
314+ let patchWaitingFor = PatchMap $ Map.fromList $ (\(n, _, dec) -> (n, Just dec)) <$> results
315+ let toSend = Map.fromList $ (\(n, rawRequest, _) -> (n, rawRequest)) <$> results
316+ return (patchWaitingFor, toSend)
317+
318+ -- Looks up the each incoming raw response in a map of response
319+ -- decoders and returns the decoded response and a patch that can
320+ -- be used to clear the ID of the consumed response out of the queue
321+ -- of expected responses.
322+ processIncoming
323+ :: Incremental t (PatchMap Int (Decoder rawResponse response (PrimState m)))
324+ -- A map of outstanding expected responses
325+ -> Event t (Int, rawResponse)
326+ -- A incoming response paired with its identifying key
327+ -> Event t (ResponseData (PrimState m) response, PatchMap Int v)
328+ -- The decoded response and a patch that clears the outstanding responses queue
329+ processIncoming incWaitingFor inc = flip push inc $ \(n, rawRsp) -> do
330+ waitingFor <- sample $ currentIncremental incWaitingFor
331+ case Map.lookup n waitingFor of
332+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
333+ Just (Decoder tagGen responseDecoder) -> do
334+ let rsp = responseDecoder rawRsp
335+ return $ Just
336+ ( singletonRequesterData @m tagGen (unsafeTagFromId n) rsp
337+ , PatchMap $ Map.singleton n Nothing
338+ )
339+
340+singletonRequesterData :: TagGen (PrimState m) a -> Tag (PrimState m) a -> response a -> ResponseData (PrimState m) response
341+singletonRequesterData tagGen tag response =
342+ ResponseData tagGen $ TagMap.singletonTagMap tag response
343+
344+{--
345+ src/Reflex/Requester/Base/Internal.hs:304:40-78: error:
346+ • Couldn't match type ‘s1’ with ‘s’
347+ ‘s1’ is a rigid type variable bound by
348+ a pattern with constructor:
349+ RequestData :: forall ps (request :: * -> *) s.
350+ TagGen ps s
351+ -> NonEmptyDeferred (RequestEnvelope s request)
352+ -> RequestData ps request,
353+ in an equation for ‘requesterDataToList’
354+ at src/Reflex/Requester/Base/Internal.hs:303:22-50
355+ ‘s’ is a rigid type variable bound by
356+ the type signature for:
357+ requesterDataToList :: forall (m :: * -> *) (request :: * ->
358+ *) s.
359+ RequestData (PrimState m) request ->
360+ [DSum (Tag s) request]
361+ at src/Reflex/Requester/Base/Internal.hs:302:1-102
362+ Expected type: [RequestEnvelope s request]
363+ Actual type: [RequestEnvelope s1 request]
364+ • In the second argument of ‘($)’, namely
365+ ‘NonEmptyDeferred.toList requestEnvelope’
366+ In the expression:
367+ requestEnvelopesToList @s @request
368+ $ NonEmptyDeferred.toList requestEnvelope
369+--}
370+requesterDataToList :: forall m request s. RequestData (PrimState m) request -> [DSum (Tag s) request]
371+requesterDataToList (RequestData _ requestEnvelope) =
372+ requestEnvelopesToList @s @request $ NonEmptyDeferred.toList requestEnvelope
373+
374+requestEnvelopesToList :: forall s request. [RequestEnvelope s request] -> [DSum (Tag s) request]
375+requestEnvelopesToList reqEnvs = f <$> reqEnvs
376+ where f :: (RequestEnvelope s request)-> DSum (Tag s) request
377+ f (RequestEnvelope (Just tag) v) = tag :=> v