Fix matchResponseMapWithRequests to handle prompt response.

src/Reflex/Requester/Base/Internal.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE RecursiveDo #-}
@@ -59,6 +60,7 @@ import Data.Monoid ((<>))
 import Data.Proxy
 import qualified Data.Semigroup as S
 import Data.Some (Some(Some))
+import Data.These
 import Data.Type.Equality
 import Data.Unique.Tag
 
@@ -547,12 +549,18 @@ matchResponseMapWithRequests
 matchResponseMapWithRequests f send recv = do
   rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
       waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
-        holdIncremental mempty $ leftmost
-          [ fmap (\(_, outstanding, _) -> outstanding) outgoing
-          , snd <$> incoming
-          ]
+        holdIncremental mempty $
+          alignEventWithMaybe
+            ( Just . \case
+                These x y -> y <> x
+                This x -> x
+                That x -> x
+            )
+            outstanding
+            (snd <$> incoming)
       let outgoing = processOutgoing nextId send
-          incoming = processIncoming waitingFor recv
+          incoming = processIncoming waitingFor outstanding recv
+          outstanding = fmap (\(_, outstanding, _) -> outstanding) outgoing
   return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
   where
     -- Tags each outgoing request with an identifying integer key
@@ -570,31 +578,46 @@ matchResponseMapWithRequests f send recv = do
       -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
     processOutgoing nextId out = flip pushAlways out $ \dm -> do
       oldNextId <- sample nextId
-      let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
+      let (result, newNextId) = flip runState oldNextId $
+            forM (requesterDataToList dm) $ \(k :=> v) -> do
             n <- get
             put $ succ n
             let (rawReq, rspF) = f v
             return (n, rawReq, Decoder k rspF)
-          patchWaitingFor = PatchMap $ Map.fromList $
+          patchWaitingFor =
+            PatchMap $
+              Map.fromList $
             (\(n, _, dec) -> (n, Just dec)) <$> result
           toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
       return (newNextId, patchWaitingFor, toSend)
     -- Looks up the each incoming raw response in a map of response
     -- decoders and returns the decoded response and a patch that can
     -- be used to clear the ID of the consumed response out of the queue
     -- of expected responses.
-    processIncoming
+    processIncoming 
       :: Incremental t (PatchMap Int (Decoder rawResponse response))
       -- A map of outstanding expected responses
+      -> Event t (PatchMap Int (Decoder rawResponse response))
+      -- A map of response decoders for prompt responses
       -> Event t (Map Int rawResponse)
       -- A incoming response paired with its identifying key
       -> Event t (RequesterData response, PatchMap Int v)
       -- The decoded response and a patch that clears the outstanding responses queue
-    processIncoming waitingFor inc = flip push inc $ \rspMap -> do
-      wf <- sample $ currentIncremental waitingFor
+    processIncoming waitingFor outstanding inc = flip push (alignEventWithMaybe thatMaybe inc outstanding) $ \(rspMap, promptRspMap) -> do
+      wf' <- sample $ currentIncremental waitingFor
+      let wf = maybe id applyAlways promptRspMap wf'
       let match rawRsp (Decoder k rspF) =
             let rsp = rspF rawRsp
             in singletonRequesterData k rsp
           matches = Map.intersectionWith match rspMap wf
-      pure $ if Map.null matches then Nothing else Just
+      pure $
+        if Map.null matches
+          then Nothing
+          else
+            Just
         (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
+    thatMaybe :: These a b -> Maybe (a, Maybe b)
+    thatMaybe = \case
+      This x -> Just (x, Nothing)
+      That x -> Nothing
+      These x y -> Just (x, Just y)