lsp-test 0.15.0.1 → 0.16.0.0

raw patch · 9 files changed

+190/−53 lines, 9 filesdep +lens-aesondep ~lspPVP ok

version bump matches the API change (PVP)

Dependencies added: lens-aeson

Dependency ranges changed: lsp

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• bench/SimpleBench.hs +3/−1
• func-test/FuncTest.hs +6/−2
• lsp-test.cabal +4/−3
• src/Language/LSP/Test.hs +50/−5
• src/Language/LSP/Test/Parsing.hs +12/−0
• src/Language/LSP/Test/Session.hs +55/−23
• test/DummyServer.hs +16/−4
• test/Test.hs +31/−15

@@ -1,5 +1,18 @@ # Revision history for lsp-test +## 0.16.0.0++- The client configuration is now _mandatory_ and is an `Object` rather than a `Value`.+- `lsp-test` now responds to `workspace/configuration` requests.+- `lsp-test` does _not_ send a `workspace/didChangeConfiguration` request on startup.+- New functions for modifying the client configuration and notifying the server.+- `ignoreLogNotifications` is now _on by default_. Experience shows the norm is to ignore these+  and it is simpler to turn this on only when they are required.+- `ignoreConfigurationRequests` option to ignore `workspace/configuration` requests, also on+  by default.+- New functions `setIgnoringLogNotifications` and `setIgnoringConfigurationRequests` to change+  whether such messages are ignored during a `Session` without having to change the `SessionConfig`.+ ## 0.15.0.1  * Adds helper functions to resolve code lens, code actions, and completion items.

@@ -32,8 +32,10 @@  server :: ServerDefinition () server = ServerDefinition-  { onConfigurationChange = const $ const $ Right ()+  { parseConfig = const $ const $ Right ()+  , onConfigChange = const  $ pure ()   , defaultConfig = ()+  , configSection = "demo"   , doInitialize = \env _req -> pure $ Right env   , staticHandlers = \_caps -> handlers   , interpretHandler = \env -> Iso (runLspT env) liftIO

@@ -32,8 +32,10 @@       killVar <- newEmptyMVar        let definition = ServerDefinition-            { onConfigurationChange = const $ const $ Right ()+            { parseConfig = const $ const $ Right ()+            , onConfigChange = const $ pure ()             , defaultConfig = ()+            , configSection = "demo"             , doInitialize = \env _req -> pure $ Right env             , staticHandlers = \_caps -> handlers killVar             , interpretHandler = \env -> Iso (runLspT env) liftIO@@ -79,8 +81,10 @@           wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"                      definition = ServerDefinition-            { onConfigurationChange = const $ const $ Right ()+            { parseConfig = const $ const $ Right ()+            , onConfigChange = const $ pure ()             , defaultConfig = ()+            , configSection = "demo"             , doInitialize = \env _req -> pure $ Right env             , staticHandlers = \_caps -> handlers             , interpretHandler = \env -> Iso (runLspT env) liftIO

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               lsp-test-version:            0.15.0.1+version:            0.16.0.0 synopsis:           Functional test framework for LSP servers. description:   A test framework for writing tests against@@ -59,7 +59,8 @@     , filepath     , Glob                  >=0.9   && <0.11     , lens-    , lsp                   ^>=2.1+    , lens-aeson+    , lsp                   ^>=2.2     , lsp-types             ^>=2.0     , mtl                   <2.4     , parser-combinators    >=1.2@@ -102,7 +103,7 @@     , filepath     , hspec     , lens-    , lsp           ^>=2.1+    , lsp           ^>=2.2     , lsp-test     , mtl           <2.4     , parser-combinators

@@ -29,6 +29,8 @@   , runSessionWithConfigCustomProcess   , runSessionWithHandles   , runSessionWithHandles'+  , setIgnoringLogNotifications+  , setIgnoringConfigurationRequests   -- ** Config   , SessionConfig(..)   , defaultConfig@@ -49,6 +51,11 @@    -- ** Initialization   , initializeResponse+  -- ** Config+  , modifyConfig+  , setConfig+  , modifyConfigSection+  , setConfigSection   -- ** Documents   , createDoc   , openDoc@@ -121,6 +128,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson hiding (Null)+import qualified Data.Aeson as J import Data.Default import Data.List import Data.Maybe@@ -143,6 +151,7 @@ import qualified System.FilePath.Glob as Glob import Control.Monad.State (execState) import Data.Traversable (for)+import Data.String (fromString)  -- | Starts a new session. --@@ -224,7 +233,8 @@                                           Nothing                                           (InL $ filePathToUri absRootDir)                                           caps-                                          (lspConfig config')+                                          -- TODO: make this configurable?+                                          (Just $ Object $ lspConfig config')                                           (Just TraceValues_Off)                                           (fmap InL $ initialWorkspaceFolders config)   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do@@ -243,10 +253,6 @@     liftIO $ putMVar initRspVar initRspMsg     sendNotification SMethod_Initialized InitializedParams -    case lspConfig config of-      Just cfg -> sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)-      Nothing -> return ()-     -- ... relay them back to the user Session so they can match on them!     -- As long as they are allowed.     forM_ inBetween checkLegalBetweenMessage@@ -400,6 +406,45 @@ -- so if you need to test it use this. initializeResponse :: Session (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp++setIgnoringLogNotifications :: Bool -> Session ()+setIgnoringLogNotifications value = do+  modify (\ss -> ss { ignoringLogNotifications = value })++setIgnoringConfigurationRequests :: Bool -> Session ()+setIgnoringConfigurationRequests value = do+  modify (\ss -> ss { ignoringConfigurationRequests = value })++-- | Modify the client config. This will send a notification to the server that the+-- config has changed.+modifyConfig :: (Object -> Object) -> Session ()+modifyConfig f = do+  oldConfig <- curLspConfig <$> get+  let newConfig = f oldConfig+  modify (\ss -> ss { curLspConfig = newConfig })++  caps <- asks sessionCapabilities+  let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just+      -- TODO: make this configurable?+      -- if they support workspace/configuration then be annoying and don't send the full config so+      -- they have to request it+      configToSend = if supportsConfiguration then J.Null else Object newConfig+  sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend++-- | Set the client config. This will send a notification to the server that the+-- config has changed.+setConfig :: Object -> Session ()+setConfig newConfig = modifyConfig (const newConfig)++-- | Modify a client config section (if already present, otherwise does nothing).+-- This will send a notification to the server that the config has changed.+modifyConfigSection :: String -> (Value -> Value) -> Session ()+modifyConfigSection section f = modifyConfig (\o -> o & ix (fromString section) %~ f)++-- | Set a client config section. This will send a notification to the server that the+-- config has changed.+setConfigSection :: String -> Value -> Session ()+setConfigSection section settings = modifyConfig (\o -> o & at(fromString section) ?~ settings)  -- | /Creates/ a new text document. This is different from 'openDoc' -- as it sends a workspace/didChangeWatchedFiles notification letting the server

@@ -20,6 +20,8 @@   , anyNotification   , anyMessage   , loggingNotification+  , configurationRequest+  , loggingOrConfiguration   , publishDiagnosticsNotification   ) where @@ -206,6 +208,16 @@     shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True     shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True     shouldSkip _ = False++-- | Matches if the message is a configuration request from the server.+configurationRequest :: Session FromServerMessage+configurationRequest = named "Configuration request" $ satisfy shouldSkip+  where+    shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True+    shouldSkip _ = False++loggingOrConfiguration :: Session FromServerMessage+loggingOrConfiguration = loggingNotification <|> configurationRequest  -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' -- (textDocument/publishDiagnostics) notification.

@@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}  module Language.LSP.Test.Session   ( Session(..)@@ -41,10 +42,10 @@ import Control.Exception import Control.Lens hiding (List, Empty) import Control.Monad-import Control.Monad.Catch (MonadThrow)-import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Except #if __GLASGOW_HASKELL__ == 806 import Control.Monad.Fail #endif@@ -55,6 +56,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson hiding (Error, Null) import Data.Aeson.Encode.Pretty+import Data.Aeson.Lens () import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default@@ -84,6 +86,8 @@ import Data.IORef import Colog.Core (LogAction (..), WithSeverity (..), Severity (..)) import Data.Row+import Data.String (fromString)+import Data.Either (partitionEithers)  -- | A session representing one instance of launching and connecting to a server. --@@ -112,12 +116,18 @@   -- ^ Trace the messages sent and received to stdout, defaults to False.   -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.   , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.-  , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.+  , lspConfig      :: Object+  -- ^ The initial LSP config as JSON object, defaults to the empty object.+  -- This should include the config section for the server if it has one, i.e. if+  -- the server has a 'mylang' config section, then the config should be an object+  -- 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 'Language.LSP.Types.ShowMessageNotification' and-  -- 'Language.LSP.Types.LogMessageNotification', defaults to False.-  ---  -- @since 0.9.0.0+  -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications +  -- from the server, defaults to True.+  , ignoreConfigurationRequests :: Bool+  -- ^ Whether or not to ignore @workspace/configuration@ requests from the server,+  -- defaults to True.   , initialWorkspaceFolders :: Maybe [WorkspaceFolder]   -- ^ The initial workspace folders to send in the @initialize@ request.   -- Defaults to Nothing.@@ -125,7 +135,7 @@  -- | The configuration used in 'Language.LSP.Test.runSession'. defaultConfig :: SessionConfig-defaultConfig = SessionConfig 60 False False True Nothing False Nothing+defaultConfig = SessionConfig 60 False False True mempty True True Nothing  instance Default SessionConfig where   def = defaultConfig@@ -181,7 +191,10 @@   , curDynCaps :: !(Map.Map T.Text SomeRegistration)   -- ^ The capabilities that the server has dynamically registered with us so   -- far+  , curLspConfig :: Object   , curProgressSessions :: !(Set.Set ProgressToken)+  , ignoringLogNotifications :: Bool+  , ignoringConfigurationRequests :: Bool   }  class Monad m => HasState s m where@@ -227,15 +240,9 @@      chanSource = do       msg <- liftIO $ readChan (messageChan context)-      unless (ignoreLogNotifications (config context) && isLogNotification msg) $-        yield msg+      yield msg       chanSource -    isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowMessage _)) = True-    isLogNotification (ServerMessage (FromServerMess SMethod_WindowLogMessage _)) = True-    isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowDocument _)) = True-    isLogNotification _ = False-     watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()     watchdog = Conduit.awaitForever $ \msg -> do       curId <- getCurTimeoutId@@ -273,7 +280,7 @@   mainThreadId <- myThreadId    let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps-      initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty+      initState vfs = SessionState 0 vfs mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config)       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses        errorHandler = throwTo mainThreadId :: SessionException -> IO ()@@ -302,17 +309,42 @@  updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () updateStateC = awaitForever $ \msg -> do+  state <- get @SessionState   updateState msg-  respond msg-  yield msg-  where-    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()-    respond (FromServerMess SMethod_WindowWorkDoneProgressCreate req) =+  case msg of+    FromServerMess SMethod_WindowWorkDoneProgressCreate req ->       sendMessage $ TResponseMessage "2.0" (Just $ req ^. L.id) (Right Null)-    respond (FromServerMess SMethod_WorkspaceApplyEdit r) = do+    FromServerMess SMethod_WorkspaceApplyEdit r -> do       sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right $ ApplyWorkspaceEditResult True Nothing Nothing)-    respond _ = pure ()+    FromServerMess SMethod_WorkspaceConfiguration r -> do+      let requestedSections = mapMaybe (\i -> i ^? L.section . _Just) $ r ^. L.params . L.items+      let o = curLspConfig state+      -- check for each requested section whether we have it+      let configsOrErrs = (flip fmap) requestedSections $ \section ->+            case o ^. at (fromString $ T.unpack section) of+              Just config -> Right config+              Nothing -> Left section +      let (errs, configs) = partitionEithers configsOrErrs++      -- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error+      if null errs+      then sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right configs)+      else sendMessage @_ @(TResponseError Method_WorkspaceConfiguration) $+        TResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing+    _ -> pure ()+  unless ((ignoringLogNotifications state && isLogNotification msg) || (ignoringConfigurationRequests state && isConfigRequest msg)) $+    yield msg++  where++    isLogNotification (FromServerMess SMethod_WindowShowMessage _) = True+    isLogNotification (FromServerMess SMethod_WindowLogMessage _) = True+    isLogNotification (FromServerMess SMethod_WindowShowDocument _) = True+    isLogNotification _ = False++    isConfigRequest (FromServerMess SMethod_WorkspaceConfiguration _) = True+    isConfigRequest _ = False  -- extract Uri out from DocumentChange -- didn't put this in `lsp-types` because TH was getting in the way

@@ -7,8 +7,10 @@ import Control.Monad import Control.Monad.Reader import Data.Aeson hiding (defaultOptions, Null)+import qualified Data.Aeson as J import qualified Data.Map.Strict as M import Data.List (isSuffixOf)+import qualified Data.Text as T import Data.String import UnliftIO.Concurrent import Language.LSP.Server@@ -27,10 +29,15 @@   (houtRead, houtWrite) <- createPipe    handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar-  let definition = ServerDefinition+  let+    definition = ServerDefinition         { doInitialize = \env _req -> pure $ Right env-        , defaultConfig = ()-        , onConfigurationChange = const $ pure $ Right ()+        , defaultConfig = 1 :: Int+        , configSection = "dummy"+        , parseConfig = \_old new -> case fromJSON new of+            J.Success v -> Right v+            J.Error err -> Left $ T.pack err+        , onConfigChange = const $ pure ()         , staticHandlers = \_caps -> handlers         , interpretHandler = \env ->             Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO@@ -48,13 +55,18 @@   , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)   } -handlers :: Handlers (ReaderT HandlerEnv (LspM ()))+handlers :: Handlers (ReaderT HandlerEnv (LspM Int)) handlers =   mconcat     [ notificationHandler SMethod_Initialized $         \_noti ->           sendNotification SMethod_WindowLogMessage $             LogMessageParams MessageType_Log "initialized"++    , requestHandler (SMethod_CustomMethod (Proxy @"getConfig")) $ \_req resp -> do+        config <- getConfig+        resp $ Right $ toJSON config+     , requestHandler SMethod_TextDocumentHover $         \_req responder ->           responder $

@@ -8,6 +8,7 @@ import DummyServer import           Test.Hspec import           Data.Aeson+import qualified Data.Aeson as J import           Data.Default import qualified Data.Map.Strict as M import           Data.Either@@ -103,14 +104,12 @@     describe "SessionException" $ do       it "throw on time out" $ \(hin, hout) ->         let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do-                skipMany loggingNotification                 _ <- message SMethod_WorkspaceApplyEdit                 return ()         in sesh `shouldThrow` anySessionException        it "don't throw when no time out" $ \(hin, hout) ->         runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do-          loggingNotification           liftIO $ threadDelay $ 6 * 1000000           _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"           return ()@@ -119,7 +118,7 @@         it "throws when there's an unexpected message" $ \(hin, hout) ->           let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True               selector _ = False-            in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector+            in runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector         it "provides the correct types that were expected and received" $ \(hin, hout) ->           let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True               selector _ = False@@ -131,6 +130,29 @@             in runSessionWithHandles hin hout def fullCaps "." sesh               `shouldThrow` selector +  describe "config" $ do+    it "updates config correctly" $ \(hin, hout) ->+      runSessionWithHandles hin hout (def { ignoreConfigurationRequests = False }) fullCaps "." $ do+        configurationRequest -- initialized configuration request+        let requestConfig = do+              resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null+              case resp ^? L.result . _Right of+                Just val -> case fromJSON @Int val of+                  J.Success v -> pure v+                  J.Error err -> fail err+                Nothing -> fail "no result"++        c <- requestConfig+        -- from the server definition+        liftIO $ c `shouldBe` 1+        setConfigSection "dummy" (toJSON @Int 2)+        -- ensure the configuration change has happened+        configurationRequest+        c <- requestConfig+        liftIO $ c `shouldBe` 2++        pure ()+   describe "text document VFS" $ do     it "sends back didChange notifications (documentChanges)" $ \(hin, hout) ->       runSessionWithHandles hin hout def fullCaps "." $ do@@ -213,8 +235,6 @@     it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do       doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -      skipMany loggingNotification-       Right (mainSymbol:_) <- getDocumentSymbols doc        liftIO $ do@@ -324,21 +344,21 @@       in sesh `shouldThrow` anyException    describe "satisfy" $-    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do       openDoc "test/data/Format.hs" "haskell"       let pred (FromServerMess SMethod_WindowLogMessage _) = True           pred _ = False       void $ satisfy pred    describe "satisfyMaybe" $ do-    it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+    it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do       -- Wait for window/logMessage "initialized" from the server.       let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String           pred _ = Nothing :: Maybe String       result <- satisfyMaybe pred       liftIO $ result `shouldBe` "match" -    it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+    it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do       let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String           pred _ = Nothing :: Maybe String       -- We expect a window/logMessage from the server, but@@ -354,9 +374,8 @@    describe "dynamic capabilities" $ do -    it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+    it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do       loggingNotification -- initialized log message-       createDoc ".register" "haskell" ""       message SMethod_ClientRegisterCapability @@ -378,13 +397,11 @@        createDoc "Bar.watch" "haskell" ""       void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing-      count 0 $ loggingNotification       void $ anyResponse -    it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "" $ do-      curDir <- liftIO $ getCurrentDirectory-+    it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "" $ do       loggingNotification -- initialized log message+      curDir <- liftIO $ getCurrentDirectory        createDoc ".register.abs" "haskell" ""       message SMethod_ClientRegisterCapability@@ -399,7 +416,6 @@        createDoc (curDir </> "Bar.watch") "haskell" ""       void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing-      count 0 $ loggingNotification       void $ anyResponse    describe "call hierarchy" $ do