X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FLSP%2FTest%2FParsing.hs;h=247f969862f2ad25a42ad3dc10e6de4802509201;hb=0132314e3f91ad3ba9e0405e53f5dca6f5d46ab1;hp=e55909f4c59fc9076c665d9b8f66811ae9981bb9;hpb=55ae6885312a90117aab35acdfc470790f30cfca;p=lsp-test.git

diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs
index e55909f..247f969 100644
--- a/src/Language/LSP/Test/Parsing.hs
+++ b/src/Language/LSP/Test/Parsing.hs
@@ -83,16 +83,21 @@ satisfyMaybeM pred = do
   
   skipTimeout <- overridingTimeout <$> get
   timeoutId <- getCurTimeoutId
-  unless skipTimeout $ do
+  mtid <-
+    if skipTimeout
+    then pure Nothing
+    else Just <$> do
       chan <- asks messageChan
       timeout <- asks (messageTimeout . config)
-    void $ liftIO $ forkIO $ do
+      liftIO $ forkIO $ do
         threadDelay (timeout * 1000000)
         writeChan chan (TimeoutMessage timeoutId)
 
   x <- Session await
 
-  unless skipTimeout (bumpTimeoutId timeoutId)
+  forM_ mtid $ \tid -> do
+    bumpTimeoutId timeoutId
+    liftIO $ killThread tid
 
   modify $ \s -> s { lastReceivedMessage = Just x }
 
@@ -112,8 +117,10 @@ named s (Session x) = Session (Data.Conduit.Parser.named s x)
 message :: SServerMethod m -> Session (ServerMessage m)
 message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case
   FromServerMess m2 msg -> do
-    HRefl <- mEqServer m1 m2
-    pure msg
+    res <- mEqServer m1 m2
+    case res of
+      Right HRefl -> pure msg
+      Left f -> Nothing
   _ -> Nothing
 
 customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
@@ -163,7 +170,7 @@ anyResponse = named "Any response" $ satisfy $ \case
 response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
 response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case
   FromServerRsp m2 msg -> do
-    HRefl <- mEqClient m1 m2
+    HRefl <- runEq mEqClient m1 m2
     pure msg
   _ -> Nothing
 
@@ -173,17 +180,10 @@ responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
   satisfyMaybe $ \msg -> do
     case msg of
       FromServerMess _ _ -> Nothing
-      FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
-        case mEqClient m m' of
-          Just HRefl -> do
-            guard (lid' == Just lid)
+      FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do
+        HRefl <- runEq mEqClient m m'
+        guard (Just lid == lid')
         pure rspMsg
-          Nothing
-            | SCustomMethod tm <- m
-            , SCustomMethod tm' <- m'
-            , tm == tm'
-            , lid' == Just lid -> pure rspMsg
-          _ -> empty
 
 -- | Matches any type of message.
 anyMessage :: Session FromServerMessage