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