lsp-test: add setIgnoringProgressNotifications

lsp-test/ChangeLog.md

@@ -1,10 +1,15 @@
 # Revision history for lsp-test
 
+# Unreleased
+
+- New function `setIgnoringProgressNotifications` to change whether progress notifications are
+  ignored during a `Session` without having to change the `SessionConfig`.
+
 ## 0.17.0.0
 
 - `ignoreRegistrationRequests` option to ignore `client/registerCapability` requests, on
   by default.
-- New functions `setIgnoringRegistrationRequests` to change whether such messages are 
+- New function `setIgnoringRegistrationRequests` to change whether such messages are
   ignored during a `Session` without having to change the `SessionConfig`.
 - `lsp-test` will no longer send `workspace/didChangConfiguration` notifications unless
   the server dynamically registers for them.
@@ -44,7 +49,7 @@
 
 * Compatibility with new `lsp-types` major version.
 
-## 0.14.0.2 
+## 0.14.0.2
 
 * Compatibility with new `lsp-types` major version.
 

lsp-test/func-test/FuncTest.hs

@@ -79,6 +79,7 @@ spec = do
                 updater $ ProgressAmount (Just 75) (Just "step3")
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
+        Test.setIgnoringProgressNotifications False
         Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
 
         -- Wait until we have seen a begin messsage. This means that the token setup
@@ -137,6 +138,7 @@ spec = do
                 liftIO $ threadDelay (1 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
+        Test.setIgnoringProgressNotifications False
         Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
 
         -- Wait until we have created the progress so the updates will be sent individually
@@ -183,6 +185,7 @@ spec = do
                   Control.Exception.throwIO AsyncCancelled
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
+        Test.setIgnoringProgressNotifications False
         -- First make sure that we get a $/progress begin notification
         skipManyTill Test.anyMessage $ do
           x <- Test.message SMethod_Progress
@@ -219,6 +222,7 @@ spec = do
                 updater $ ProgressAmount (Just 75) (Just "step3")
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
+        Test.setIgnoringProgressNotifications False
         Test.sendRequest SMethod_TextDocumentCodeLens (CodeLensParams (Just $ ProgressToken $ InR "hello") Nothing (TextDocumentIdentifier $ Uri "."))
 
         -- First make sure that we get a $/progress begin notification
@@ -297,6 +301,7 @@ spec = do
              in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps
 
       runSessionWithServer logger definition config Test.fullCaps "." $ do
+        Test.setIgnoringProgressNotifications False
         changeFolders [wf1] []
         changeFolders [wf2] [wf1]
 

lsp-test/src/Language/LSP/Test.hs

@@ -24,6 +24,7 @@ module Language.LSP.Test (
   runSessionWithHandles,
   runSessionWithHandles',
   setIgnoringLogNotifications,
+  setIgnoringProgressNotifications,
   setIgnoringConfigurationRequests,
   setIgnoringRegistrationRequests,
 
@@ -472,15 +473,19 @@ initializeResponse :: Session (TResponseMessage Method_Initialize)
 initializeResponse = ask >>= (liftIO . readMVar) . initRsp
 
 setIgnoringLogNotifications :: Bool -> Session ()
-setIgnoringLogNotifications value = do
+setIgnoringLogNotifications value =
   modify (\ss -> ss{ignoringLogNotifications = value})
 
+setIgnoringProgressNotifications :: Bool -> Session ()
+setIgnoringProgressNotifications value =
+  modify (\ss -> ss{ignoringProgressNotifications = value})
+
 setIgnoringConfigurationRequests :: Bool -> Session ()
-setIgnoringConfigurationRequests value = do
+setIgnoringConfigurationRequests value =
   modify (\ss -> ss{ignoringConfigurationRequests = value})
 
 setIgnoringRegistrationRequests :: Bool -> Session ()
-setIgnoringRegistrationRequests value = do
+setIgnoringRegistrationRequests value =
   modify (\ss -> ss{ignoringRegistrationRequests = value})
 
 {- | Modify the client config. This will send a notification to the server that the

lsp-test/src/Language/LSP/Test/Session.hs

@@ -118,13 +118,15 @@ data SessionConfig = SessionConfig
   -- with a 'mylang' key whose value is the actual config for the server. You
   -- can also include other config sections if your server may request those.
   , ignoreLogNotifications :: Bool
-  -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications 
+  -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications
   -- from the server, defaults to True.
+  , ignoreProgressNotifications :: Bool
+  -- ^ Whether or not to ignore @$/progress@ notifications from the server, defaults to True.
   , ignoreConfigurationRequests :: Bool
   -- ^ Whether or not to ignore @workspace/configuration@ requests from the server,
   -- defaults to True.
   , ignoreRegistrationRequests :: Bool
-  -- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@ 
+  -- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@
   -- requests from the server, defaults to True.
   , initialWorkspaceFolders :: Maybe [WorkspaceFolder]
   -- ^ The initial workspace folders to send in the @initialize@ request.
@@ -133,7 +135,7 @@ data SessionConfig = SessionConfig
 
 -- | The configuration used in 'Language.LSP.Test.runSession'.
 defaultConfig :: SessionConfig
-defaultConfig = SessionConfig 60 False False True mempty True True True Nothing
+defaultConfig = SessionConfig 60 False False True mempty True True True True Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -192,6 +194,7 @@ data SessionState = SessionState
   , curLspConfig :: Object
   , curProgressSessions :: !(Set.Set ProgressToken)
   , ignoringLogNotifications :: Bool
+  , ignoringProgressNotifications :: Bool
   , ignoringConfigurationRequests :: Bool
   , ignoringRegistrationRequests :: Bool
   }
@@ -297,6 +300,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
         (lspConfig config)
         mempty
         (ignoreLogNotifications config)
+        (ignoreProgressNotifications config)
         (ignoreConfigurationRequests config)
         (ignoreRegistrationRequests config)
       runSession' = runSessionMonad context initState
@@ -347,12 +351,13 @@ updateStateC = awaitForever $ \msg -> do
 
       -- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error
       sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) $
-        if null errs 
+        if null errs
         then (Right configs)
         else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing
     _ -> pure ()
   unless (
     (ignoringLogNotifications state && isLogNotification msg)
+    || (ignoringProgressNotifications state && isProgressNotification msg)
     || (ignoringConfigurationRequests state && isConfigRequest msg)
     || (ignoringRegistrationRequests state && isRegistrationRequest msg)) $
     yield msg
@@ -364,6 +369,9 @@ updateStateC = awaitForever $ \msg -> do
     isLogNotification (FromServerMess SMethod_WindowShowDocument _) = True
     isLogNotification _ = False
 
+    isProgressNotification (FromServerMess SMethod_Progress _) = True
+    isProgressNotification _ = False
+
     isConfigRequest (FromServerMess SMethod_WorkspaceConfiguration _) = True
     isConfigRequest _ = False