@@ -31,6 +31,7 @@ module Reflex.Requester.Base
3131 , forRequesterData
3232 , requesterDataToList
3333 , singletonRequesterData
34+ , matchResponsesWithRequests
3435 , multiEntry
3536 , unMultiEntry
3637 , requesting'
@@ -454,3 +455,84 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
454455 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
455456 requests <- holdIncremental requests0 requests'
456457 return (result0, result')
458+
459+data Decoder rawResponse response =
460+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
461+
462+-- | Matches incoming responses with previously-sent requests
463+-- and uses the provided request "decoder" function to process
464+-- incoming responses.
465+matchResponsesWithRequests
466+ :: forall t rawRequest rawResponse request response m.
467+ ( MonadFix m
468+ , MonadHold t m
469+ , Reflex t
470+ )
471+ => (forall a. request a -> (rawRequest, rawResponse -> response a))
472+ -- ^ Given a request (from 'Requester'), produces the wire format of the
473+ -- request and a function used to process the associated response
474+ -> Event t (RequesterData request)
475+ -- ^ The outgoing requests
476+ -> Event t (Int, rawResponse)
477+ -- ^ The incoming responses, tagged by an identifying key
478+ -> m ( Event t (Map Int rawRequest)
479+ , Event t (RequesterData response)
480+ )
481+ -- ^ A map of outgoing wire-format requests and an event of responses keyed
482+ -- by the 'RequesterData' key of the associated outgoing request
483+matchResponsesWithRequests f send recv = do
484+ rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
485+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
486+ holdIncremental mempty $ leftmost
487+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing
488+ , snd <$> incoming
489+ ]
490+ let outgoing = processOutgoing nextId send
491+ incoming = processIncoming waitingFor recv
492+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
493+ where
494+ -- Tags each outgoing request with an identifying integer key
495+ -- and returns the next available key, a map of response decoders
496+ -- for requests for which there are outstanding responses, and the
497+ -- raw requests to be sent out.
498+ processOutgoing
499+ :: Behavior t Int
500+ -- The next available key
501+ -> Event t (RequesterData request)
502+ -- The outgoing request
503+ -> Event t ( Int
504+ , PatchMap Int (Decoder rawResponse response)
505+ , Map Int rawRequest )
506+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
507+ processOutgoing nextId out = flip pushAlways out $ \dm -> do
508+ oldNextId <- sample nextId
509+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
510+ n <- get
511+ put $ succ n
512+ let (rawReq, rspF) = f v
513+ return (n, rawReq, Decoder k rspF)
514+ patchWaitingFor = PatchMap $ Map.fromList $
515+ (\(n, _, dec) -> (n, Just dec)) <$> result
516+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
517+ return (newNextId, patchWaitingFor, toSend)
518+ -- Looks up the each incoming raw response in a map of response
519+ -- decoders and returns the decoded response and a patch that can
520+ -- be used to clear the ID of the consumed response out of the queue
521+ -- of expected responses.
522+ processIncoming
523+ :: Incremental t (PatchMap Int (Decoder rawResponse response))
524+ -- A map of outstanding expected responses
525+ -> Event t (Int, rawResponse)
526+ -- A incoming response paired with its identifying key
527+ -> Event t (RequesterData response, PatchMap Int v)
528+ -- The decoded response and a patch that clears the outstanding responses queue
529+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
530+ wf <- sample $ currentIncremental waitingFor
531+ case Map.lookup n wf of
532+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
533+ Just (Decoder k rspF) -> do
534+ let rsp = rspF rawRsp
535+ return $ Just
536+ ( singletonRequesterData k rsp
537+ , PatchMap $ Map.singleton n Nothing
538+ )