X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FLSP%2FTest%2FParsing.hs;h=58785d9bf5979a7227db8d7c91d674399deda8ba;hb=6042c31e8b18eefb81b98a8ebb3e1e6f4a004907;hp=ecf8e4538cb7a4116f5a08fa9db435e0d97efc22;hpb=f89cfd8c1b3fe2b9e0805b564216ab3a5eda1b82;p=lsp-test.git

diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs
index ecf8e45..58785d9 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 }
 
@@ -110,7 +115,7 @@ named s (Session x) = Session (Data.Conduit.Parser.named s x)
 
 -- | Matches a request or a notification coming from the server.
 message :: SServerMethod m -> Session (ServerMessage m)
-message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case
   FromServerMess m2 msg -> do
     HRefl <- mEqServer m1 m2
     pure msg
@@ -161,7 +166,7 @@ anyResponse = named "Any response" $ satisfy $ \case
 
 -- | Matches a response coming from the server.
 response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
-response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case
   FromServerRsp m2 msg -> do
     HRefl <- mEqClient m1 m2
     pure msg