lsp 2.1.0.0 → 2.2.0.0

raw patch · 9 files changed

+408/−223 lines, 9 filesdep +lens-aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: lens-aeson

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• example/Reactor.hs +3/−1
• example/Simple.hs +3/−1
• lsp.cabal +2/−1
• src/Language/LSP/Server.hs +4/−0
• src/Language/LSP/Server/Control.hs +11/−6
• src/Language/LSP/Server/Core.hs +267/−134
• src/Language/LSP/Server/Processing.hs +99/−74
• src/Language/LSP/VFS.hs +6/−6

@@ -1,5 +1,18 @@ # Revision history for lsp +## 2.2.0.0++- Many changes relating to client configuration+    - `lsp` now sends `workspace/configuration` requests in response to `intialized` and+      `workspace/didChangeConfiguration` requests. It still attempts to parse configuration+      from `intializationOptions` and `workspace/didChangeConfiguration` as a fallback.+    - Servers must provide a configuration section for use in `workspace/configuration`.+    - `parseConfig` will now be called on the object corresponding to the configuration+      section, not the whole object.+    - New callback for when configuration changes, to allow servers to react.+- The logging of messages sent by the protocol has been disabled, as this can prove +  troublesome for servers that log these to the client: https://github.com/haskell/lsp/issues/447+ ## 2.1.0.0  * Fix handling of optional methods.

@@ -90,10 +90,12 @@      serverDefinition = ServerDefinition       { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 }-      , onConfigurationChange = \_old v -> do+      , parseConfig = \_old v -> do           case J.fromJSON v of             J.Error e -> Left (T.pack e)             J.Success cfg -> Right cfg+      , onConfigChange = const $ pure ()+      , configSection = "demo"       , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env)       -- Handlers log to both the client and stderr       , staticHandlers = \_caps -> lspHandlers dualLogger rin

@@ -38,8 +38,10 @@  main :: IO Int main = runServer $ 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.2 name:               lsp-version:            2.1.0.0+version:            2.2.0.0 synopsis:           Haskell library for the Microsoft Language Server Protocol description:   An implementation of the types, and basic message server to@@ -62,6 +62,7 @@     , exceptions     , filepath     , hashable+    , lens-aeson     , lens                  >=4.15.2     , lsp-types             ^>=2.0.1     , mtl                   <2.4

@@ -33,6 +33,10 @@   , sendRequest   , sendNotification +  -- * Config+  , requestConfigUpdate+  , tryChangeConfig+   -- * VFS   , getVirtualFile   , getVirtualFiles

@@ -32,7 +32,6 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text as T-import qualified Data.Text.Encoding as T import           Data.Text.Prettyprint.Doc import           Data.List import           Language.LSP.Server.Core@@ -167,16 +166,18 @@       case J.eitherDecode $ BSL.fromStrict msg of         Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error         Right initialize -> do-          mInitResp <- Processing.initializeRequestHandler serverDefinition vfs sendMsg initialize+          mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg initialize           case mInitResp of             Nothing -> pure ()             Just env -> runLspT env $ loop (parse parser remainder)   where +    pioLogger =  L.cmap (fmap LspProcessingLog) ioLogger+    pLogger =  L.cmap (fmap LspProcessingLog) logger+     loop :: Result BS.ByteString -> LspM config ()     loop = go       where-        pLogger =  L.cmap (fmap LspProcessingLog) logger         go r = do           res <- parseOne logger clientIn r           case res of@@ -210,14 +211,16 @@           pure Nothing         else go (c bs)     go (Done remainder msg) = do-      logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug+      -- TODO: figure out how to re-enable+      -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447+      -- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug       pure $ Just (msg,remainder)  -- ---------------------------------------------------------------------  -- | Simple server to make sure all output is serialised sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()-sendServer logger msgChan clientOut = do+sendServer _logger msgChan clientOut = do   forever $ do     msg <- atomically $ readTChan msgChan @@ -231,7 +234,9 @@                 , str ]      clientOut out-    logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug+    -- TODO: figure out how to re-enable+    -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447+    -- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug  -- | --

@@ -1,64 +1,70 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE BinaryLiterals             #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE DerivingVia          #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE BinaryLiterals       #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TypeInType           #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RoleAnnotations            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilyDependencies     #-}+{-# LANGUAGE TypeInType                 #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} - module Language.LSP.Server.Core where -import           Colog.Core (LogAction (..), WithSeverity (..))+import           Colog.Core                             (LogAction (..),+                                                         Severity (..),+                                                         WithSeverity (..),+                                                         (<&)) import           Control.Concurrent.Async import           Control.Concurrent.STM-import qualified Control.Exception as E+import qualified Control.Exception                      as E+import           Control.Lens                           (_Just, at, (^.), (^?)) import           Control.Monad+import           Control.Monad.Catch                    (MonadCatch, MonadMask,+                                                         MonadThrow) import           Control.Monad.Fix import           Control.Monad.IO.Class-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.Class import           Control.Monad.IO.Unlift-import           Control.Lens ( (^.), (^?), _Just, at)-import qualified Data.Aeson as J+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Identity+import           Control.Monad.Trans.Reader+import qualified Data.Aeson                             as J import           Data.Default import           Data.Functor.Product+import qualified Data.HashMap.Strict                    as HM import           Data.IxMap-import qualified Data.HashMap.Strict as HM import           Data.Kind-import qualified Data.List as L-import           Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Map.Strict as Map+import qualified Data.List                              as L+import           Data.List.NonEmpty                     (NonEmpty (..))+import qualified Data.Map.Strict                        as Map import           Data.Maybe+import           Data.Monoid                            (Ap (..))+import           Data.Ord                               (Down (Down)) import           Data.Row-import           Data.Monoid (Ap(..))-import           Data.Ord (Down (Down))-import qualified Data.Text as T-import           Data.Text ( Text )-import qualified Data.UUID as UUID-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Types as J-import qualified Language.LSP.Protocol.Lens as J-import qualified Language.LSP.Protocol.Message as J+import           Data.Text                              (Text)+import qualified Data.Text                              as T+import qualified Data.UUID                              as UUID+import           Language.LSP.Diagnostics+import qualified Language.LSP.Protocol.Lens             as L+import           Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Message          as L+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Types            as L import           Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap+import           Language.LSP.Protocol.Utils.Misc (prettyJSON) import           Language.LSP.VFS-import           Language.LSP.Diagnostics-import           System.Random hiding (next)-import           Control.Monad.Trans.Identity-import           Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow)+import           Prettyprinter+import           System.Random                          hiding (next)  -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}@@ -66,6 +72,29 @@ {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- +data LspCoreLog =+  -- TODO: arguably it would be nicer to have the config object itself in there, but+  -- then we're going to need 'Pretty config' constraints everywhere+  NewConfig J.Value+  | ConfigurationParseError J.Value T.Text+  | ConfigurationNotSupported+  | BadConfigurationResponse ResponseError+  | WrongConfigSections [J.Value]+  deriving Show++instance Pretty LspCoreLog where+  pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config+  pretty (ConfigurationNotSupported) = "LSP: not requesting configuration since the client does not support workspace/configuration"+  pretty (ConfigurationParseError settings err) =+    vsep [+      "LSP: configuration parse error:"+      , pretty err+      , "when parsing"+      , prettyJSON settings+      ]+  pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err+  pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections)+ newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a }   deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix)   deriving (Semigroup, Monoid) via (Ap (LspT config m) a)@@ -98,13 +127,15 @@  data LanguageContextEnv config =   LanguageContextEnv-  { resHandlers            :: !(Handlers IO)-  , resParseConfig         :: !(config -> J.Value -> Either T.Text config)-  , resSendMessage         :: !(FromServerMessage -> IO ())+  { resHandlers           :: !(Handlers IO)+  , resConfigSection      :: T.Text+  , resParseConfig        :: !(config -> J.Value -> Either T.Text config)+  , resOnConfigChange     :: !(config -> IO ())+  , resSendMessage        :: !(FromServerMessage -> IO ())   -- We keep the state in a TVar to be thread safe-  , resState               :: !(LanguageContextState config)-  , resClientCapabilities  :: !J.ClientCapabilities-  , resRootPath            :: !(Maybe FilePath)+  , resState              :: !(LanguageContextState config)+  , resClientCapabilities :: !L.ClientCapabilities+  , resRootPath           :: !(Maybe FilePath)   }  -- ---------------------------------------------------------------------@@ -149,7 +180,7 @@ -- | How to convert two isomorphic data structures between each other. data m <~> n   = Iso-  { forward :: forall a. m a -> n a+  { forward  :: forall a. m a -> n a   , backward :: forall a. n a -> m a   } @@ -168,15 +199,15 @@ -- | state used by the LSP dispatcher to manage the message loop data LanguageContextState config =   LanguageContextState-  { resVFS                 :: !(TVar VFSData)-  , resDiagnostics         :: !(TVar DiagnosticStore)-  , resConfig              :: !(TVar config)-  , resWorkspaceFolders    :: !(TVar [WorkspaceFolder])-  , resProgressData        :: !ProgressData-  , resPendingResponses    :: !(TVar ResponseMap)-  , resRegistrationsNot    :: !(TVar (RegistrationMap Notification))-  , resRegistrationsReq    :: !(TVar (RegistrationMap Request))-  , resLspId               :: !(TVar Int32)+  { resVFS              :: !(TVar VFSData)+  , resDiagnostics      :: !(TVar DiagnosticStore)+  , resConfig           :: !(TVar config)+  , resWorkspaceFolders :: !(TVar [WorkspaceFolder])+  , resProgressData     :: !ProgressData+  , resPendingResponses :: !(TVar ResponseMap)+  , resRegistrationsNot :: !(TVar (RegistrationMap Notification))+  , resRegistrationsReq :: !(TVar (RegistrationMap Request))+  , resLspId            :: !(TVar Int32)   }  type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)@@ -192,7 +223,7 @@  data VFSData =   VFSData-    { vfsData :: !VFS+    { vfsData    :: !VFS     , reverseMap :: !(Map.Map FilePath FilePath)     } @@ -220,7 +251,7 @@ -- If you set handlers for some requests, you may need to set some of these options. data Options =   Options-    { optTextDocumentSync                 :: Maybe J.TextDocumentSyncOptions+    { optTextDocumentSync                 :: Maybe L.TextDocumentSyncOptions     -- |  The characters that trigger completion automatically.     , optCompletionTriggerCharacters      :: Maybe [Char]     -- | The list of all possible characters that commit a completion. This field can be used@@ -274,6 +305,7 @@ -- @since 0.11.0.0 data ProgressCancellable = Cancellable | NotCancellable +-- See Note [LSP configuration] for discussion of the configuration-related fields -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the -- specific configuration data the language server needs to use.@@ -281,13 +313,29 @@   ServerDefinition     { defaultConfig :: config       -- ^ The default value we initialize the config variable to.-    , onConfigurationChange :: config -> J.Value -> Either T.Text config-      -- ^ @onConfigurationChange oldConfig newConfig@ is called whenever the-      -- clients sends a message with a changed client configuration. This-      -- callback should return either the parsed configuration data or an error-      -- indicating what went wrong. The parsed configuration object will be-      -- stored internally and can be accessed via 'config'.-      -- It is also called on the `initializationOptions` field of the InitializeParams+    , configSection :: T.Text+      -- ^ The "config section" that this server uses. This is used to identify the settings+      -- that are relevant to the server.+    , parseConfig :: config -> J.Value -> Either T.Text config+      -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we+      -- get updated configuration from the client.+      --+      -- @parseConfig@ is called on the object corresponding to the server's+      -- config section, it should not itself try to look for the config section.+      --+      -- Note that the 'J.Value' may represent only a partial object in the case where we+      -- are handling a @workspace/didChangeConfiguration@ request where the client sends+      -- only the changed settings. This is also the main circumstance where the old configuration+      -- argument is useful. It is generally fine for servers to ignore this case and just+      -- assume that the 'J.Value' represents a full new config and ignore the old configuration.+      -- This will only be problematic in the case of clients which behave as above and *also*+      -- don't support @workspace/configuration@, which is discouraged.+      --+    , onConfigChange :: config -> m ()+      -- ^ This callback is called any time the configuration is updated, with+      -- the new config. Servers that want to react to config changes should provide+      -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@+      -- handler.     , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a)       -- ^ Called *after* receiving the @initialize@ request and *before*       -- returning the response. This callback will be invoked to offer the@@ -341,7 +389,7 @@ sendNotification m params =   let msg = TNotificationMessage "2.0" m params   in case splitServerMethod m of-        IsServerNot -> sendToClient $ fromServerNot msg+        IsServerNot    -> sendToClient $ fromServerNot msg         IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg  sendRequest :: forall (m :: Method ServerToClient Request) f config. MonadLsp config f@@ -357,7 +405,7 @@    let msg = TRequestMessage "2.0" reqId m params   ~() <- case splitServerMethod m of-    IsServerReq -> sendToClient $ fromServerReq msg+    IsServerReq    -> sendToClient $ fromServerReq msg     IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg   return reqId @@ -395,7 +443,7 @@               Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs               -- TODO: Does the VFS make sense for URIs which are not files?               -- The reverse map should perhaps be (FilePath -> URI)-              Nothing -> reverseMap vfs+              Nothing     -> reverseMap vfs             !vfs' = vfs {reverseMap = revMap}             act = do               write@@ -405,11 +453,11 @@ -- | Given a text document identifier, annotate it with the latest version. getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier getVersionedTextDoc doc = do-  let uri = doc ^. J.uri+  let uri = doc ^. L.uri   mvf <- getVirtualFile (toNormalizedUri uri)   let ver = case mvf of         Just (VirtualFile lspver _ _) -> lspver-        Nothing -> 0+        Nothing                       -> 0   return (VersionedTextDocumentIdentifier uri ver)  {-# INLINE getVersionedTextDoc #-}@@ -458,7 +506,7 @@  {-# INLINE setConfig #-} -getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities+getClientCapabilities :: MonadLsp config m => m L.ClientCapabilities getClientCapabilities = resClientCapabilities <$> getLspEnv  {-# INLINE getClientCapabilities #-}@@ -472,7 +520,7 @@ getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) getWorkspaceFolders = do   clientCaps <- getClientCapabilities-  let clientSupportsWfs = fromMaybe False $ clientCaps ^? J.workspace . _Just . J.workspaceFolders . _Just+  let clientSupportsWfs = fromMaybe False $ clientCaps ^? L.workspace . _Just . L.workspaceFolders . _Just   if clientSupportsWfs     then Just <$> getsState resWorkspaceFolders     else pure Nothing@@ -493,8 +541,8 @@   clientCaps <- resClientCapabilities <$> getLspEnv   handlers <- resHandlers <$> getLspEnv   let alreadyStaticallyRegistered = case splitClientMethod method of-        IsClientNot -> SMethodMap.member method $ notHandlers handlers-        IsClientReq -> SMethodMap.member method $ reqHandlers handlers+        IsClientNot    -> SMethodMap.member method $ notHandlers handlers+        IsClientReq    -> SMethodMap.member method $ reqHandlers handlers         IsClientEither -> error "Cannot register capability for custom methods"   go clientCaps alreadyStaticallyRegistered   where@@ -505,8 +553,8 @@       -- First, check to see if the client supports dynamic registration on this method       | dynamicSupported clientCaps = do           uuid <- liftIO $ UUID.toText <$> getStdRandom random-          let registration = J.TRegistration uuid method (Just regOpts)-              params = J.RegistrationParams [toUntypedRegistration registration]+          let registration = L.TRegistration uuid method (Just regOpts)+              params = L.RegistrationParams [toUntypedRegistration registration]               regId = RegistrationId uuid           rio <- askUnliftIO           ~() <- case splitClientMethod method of@@ -526,42 +574,42 @@      -- Also I'm thinking we should move this function to somewhere in messages.hs so     -- we don't forget to update it when adding new methods...-    capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool-    capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration+    capDyn :: L.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool+    capDyn (Just x) = fromMaybe False $ x ^. L.dynamicRegistration     capDyn Nothing  = False      -- | Checks if client capabilities declares that the method supports dynamic registration     dynamicSupported clientCaps = case method of-      SMethod_WorkspaceDidChangeConfiguration  -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just-      SMethod_WorkspaceDidChangeWatchedFiles   -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just-      SMethod_WorkspaceSymbol                  -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just-      SMethod_WorkspaceExecuteCommand          -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just-      SMethod_TextDocumentDidOpen              -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just-      SMethod_TextDocumentDidChange            -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just-      SMethod_TextDocumentDidClose             -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just-      SMethod_TextDocumentCompletion           -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just-      SMethod_TextDocumentHover                -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just-      SMethod_TextDocumentSignatureHelp        -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just-      SMethod_TextDocumentDeclaration          -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just-      SMethod_TextDocumentDefinition           -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just-      SMethod_TextDocumentTypeDefinition       -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just-      SMethod_TextDocumentImplementation       -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just-      SMethod_TextDocumentReferences           -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just-      SMethod_TextDocumentDocumentHighlight    -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just-      SMethod_TextDocumentDocumentSymbol       -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just-      SMethod_TextDocumentCodeAction           -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just-      SMethod_TextDocumentCodeLens             -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just-      SMethod_TextDocumentDocumentLink         -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just-      SMethod_TextDocumentDocumentColor        -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just-      SMethod_TextDocumentColorPresentation    -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just-      SMethod_TextDocumentFormatting           -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just-      SMethod_TextDocumentRangeFormatting      -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just-      SMethod_TextDocumentOnTypeFormatting     -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just-      SMethod_TextDocumentRename               -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just-      SMethod_TextDocumentFoldingRange         -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just-      SMethod_TextDocumentSelectionRange       -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just-      SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just-      --SMethod_TextDocumentSemanticTokens       -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just+      SMethod_WorkspaceDidChangeConfiguration  -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeConfiguration . _Just+      SMethod_WorkspaceDidChangeWatchedFiles   -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just+      SMethod_WorkspaceSymbol                  -> capDyn $ clientCaps ^? L.workspace . _Just . L.symbol . _Just+      SMethod_WorkspaceExecuteCommand          -> capDyn $ clientCaps ^? L.workspace . _Just . L.executeCommand . _Just+      SMethod_TextDocumentDidOpen              -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just+      SMethod_TextDocumentDidChange            -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just+      SMethod_TextDocumentDidClose             -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just+      SMethod_TextDocumentCompletion           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.completion . _Just+      SMethod_TextDocumentHover                -> capDyn $ clientCaps ^? L.textDocument . _Just . L.hover . _Just+      SMethod_TextDocumentSignatureHelp        -> capDyn $ clientCaps ^? L.textDocument . _Just . L.signatureHelp . _Just+      SMethod_TextDocumentDeclaration          -> capDyn $ clientCaps ^? L.textDocument . _Just . L.declaration . _Just+      SMethod_TextDocumentDefinition           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.definition . _Just+      SMethod_TextDocumentTypeDefinition       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.typeDefinition . _Just+      SMethod_TextDocumentImplementation       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.implementation . _Just+      SMethod_TextDocumentReferences           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.references . _Just+      SMethod_TextDocumentDocumentHighlight    -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentHighlight . _Just+      SMethod_TextDocumentDocumentSymbol       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentSymbol . _Just+      SMethod_TextDocumentCodeAction           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just+      SMethod_TextDocumentCodeLens             -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeLens . _Just+      SMethod_TextDocumentDocumentLink         -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentLink . _Just+      SMethod_TextDocumentDocumentColor        -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just+      SMethod_TextDocumentColorPresentation    -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just+      SMethod_TextDocumentFormatting           -> capDyn $ clientCaps ^? L.textDocument . _Just . L.formatting . _Just+      SMethod_TextDocumentRangeFormatting      -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rangeFormatting . _Just+      SMethod_TextDocumentOnTypeFormatting     -> capDyn $ clientCaps ^? L.textDocument . _Just . L.onTypeFormatting . _Just+      SMethod_TextDocumentRename               -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rename . _Just+      SMethod_TextDocumentFoldingRange         -> capDyn $ clientCaps ^? L.textDocument . _Just . L.foldingRange . _Just+      SMethod_TextDocumentSelectionRange       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.selectionRange . _Just+      SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? L.textDocument . _Just . L.callHierarchy . _Just+      --SMethod_TextDocumentSemanticTokens       -> capDyn $ clientCaps ^? L.textDocument . _Just . L.semanticTokens . _Just       _                                        -> False  -- | Sends a @client/unregisterCapability@ request and removes the handler@@ -569,12 +617,12 @@ unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do   ~() <- case splitClientMethod m of-    IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m-    IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m+    IsClientReq    -> modifyState resRegistrationsReq $ SMethodMap.delete m+    IsClientNot    -> modifyState resRegistrationsNot $ SMethodMap.delete m     IsClientEither -> error "Cannot unregister capability for custom methods" -  let unregistration = J.TUnregistration uuid m-      params = J.UnregistrationParams [toUntypedUnregistration unregistration]+  let unregistration = L.TUnregistration uuid m+      params = L.UnregistrationParams [toUntypedUnregistration unregistration]   void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure ()  --------------------------------------------------------------------------------@@ -596,7 +644,7 @@ getNewProgressId = do   stateState (progressNextId . resProgressData) $ \cur ->     let !next = cur+1-    in (J.ProgressToken $ J.InL cur, next)+    in (L.ProgressToken $ L.InL cur, next)  {-# INLINE getNewProgressId #-} @@ -609,7 +657,7 @@         | indefinite = Nothing         | otherwise = Just 0       cancellable' = case cancellable of-                      Cancellable -> True+                      Cancellable    -> True                       NotCancellable -> False    -- Create progress token@@ -621,7 +669,7 @@             -- An error occurred when the client was setting it up             -- No need to do anything then, as per the spec             Left _err -> pure ()-            Right _ -> pure ()+            Right _   -> pure ()    -- Send the begin and done notifications via 'bracket_' so that they are always fired   res <- withRunInIO $ \runInBase ->@@ -629,11 +677,11 @@       -- Send begin notification       (runInBase $ sendNotification SMethod_Progress $         ProgressParams progId $ J.toJSON $-          WorkDoneProgressBegin J.AString title (Just cancellable') Nothing initialPercentage)+          WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage)        -- Send end notification       (runInBase $ sendNotification SMethod_Progress $-        ProgressParams progId $ J.toJSON $ (WorkDoneProgressEnd J.AString Nothing)) $ do+        ProgressParams progId $ J.toJSON $ (WorkDoneProgressEnd L.AString Nothing)) $ do        -- Run f asynchronously       aid <- async $ runInBase $ f (updater progId)@@ -647,10 +695,10 @@   return res   where updater progId (ProgressAmount percentage msg) = do           sendNotification SMethod_Progress $ ProgressParams progId $ J.toJSON $-              WorkDoneProgressReport J.AString Nothing msg percentage+              WorkDoneProgressReport L.AString Nothing msg percentage -clientSupportsProgress :: J.ClientCapabilities -> Bool-clientSupportsProgress caps = fromMaybe False $ caps ^? J.window . _Just . J.workDoneProgress . _Just+clientSupportsProgress :: L.ClientCapabilities -> Bool+clientSupportsProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just  {-# INLINE clientSupportsProgress #-} @@ -686,14 +734,14 @@ -- | Aggregate all diagnostics pertaining to a particular version of a document, -- by source, and sends a @textDocument/publishDiagnostics@ notification with -- the total (limited by the first parameter) whenever it is updated.-publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe J.Int32 -> DiagnosticsBySource -> m ()+publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe L.Int32 -> DiagnosticsBySource -> m () publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags->   let !newDiags = updateDiagnostics oldDiags uri version diags       mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri       act = case mdp of         Nothing -> return ()         Just params ->-          sendToClient $ J.fromServerNot $ J.TNotificationMessage "2.0" J.SMethod_TextDocumentPublishDiagnostics params+          sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params       in (act,newDiags)  -- ---------------------------------------------------------------------@@ -710,31 +758,116 @@         case mdp of           Nothing -> return ()           Just params -> do-            sendToClient $ J.fromServerNot $ J.TNotificationMessage "2.0" J.SMethod_TextDocumentPublishDiagnostics params+            sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params       in (act,newDiags)  -- ---------------------------------------------------------------------  -- | The changes in a workspace edit should be applied from the end of the file -- toward the start. Sort them into this order.-reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit-reverseSortEdit (J.WorkspaceEdit cs dcs anns) = J.WorkspaceEdit cs' dcs' anns+reverseSortEdit :: L.WorkspaceEdit -> L.WorkspaceEdit+reverseSortEdit (L.WorkspaceEdit cs dcs anns) = L.WorkspaceEdit cs' dcs' anns   where     cs' :: Maybe (Map.Map Uri [TextEdit])     cs' = (fmap . fmap ) sortTextEdits cs -    dcs' :: Maybe [J.DocumentChange]+    dcs' :: Maybe [L.DocumentChange]     dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs -    sortTextEdits :: [J.TextEdit] -> [J.TextEdit]-    sortTextEdits edits = L.sortOn (Down . (^. J.range)) edits+    sortTextEdits :: [L.TextEdit] -> [L.TextEdit]+    sortTextEdits edits = L.sortOn (Down . (^. L.range)) edits -    sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange-    sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td edits)) = J.InL $ J.TextDocumentEdit td edits'+    sortOnlyTextDocumentEdits :: L.DocumentChange -> L.DocumentChange+    sortOnlyTextDocumentEdits (L.InL (L.TextDocumentEdit td edits)) = L.InL $ L.TextDocumentEdit td edits'       where         edits' = L.sortOn (Down . editRange) edits-    sortOnlyTextDocumentEdits (J.InR others) = J.InR others+    sortOnlyTextDocumentEdits (L.InR others) = L.InR others -    editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range-    editRange (J.InR e) = e ^. J.range-    editRange (J.InL e) = e ^. J.range+    editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range+    editRange (L.InR e) = e ^. L.range+    editRange (L.InL e) = e ^. L.range++--------------------------------------------------------------------------------+-- CONFIG+--------------------------------------------------------------------------------++-- | Given a new config object, try to update our config with it.+tryChangeConfig :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> J.Value -> m ()+tryChangeConfig logger newConfigObject = do+  parseCfg <- LspT $ asks resParseConfig+  res <- stateState resConfig $ \oldConfig -> case parseCfg oldConfig newConfigObject of+    Left err         -> (Left err, oldConfig)+    Right newConfig -> (Right newConfig, newConfig)+  case res of+    Left err -> do+      logger <& ConfigurationParseError newConfigObject err `WithSeverity` Warning+    Right newConfig -> do+      logger <& NewConfig newConfigObject `WithSeverity` Debug+      cb <- LspT $ asks resOnConfigChange+      liftIO $ cb newConfig++-- | Send a `worksapce/configuration` request to update the server's config.+--+-- This is called automatically in response to `workspace/didChangeConfiguration` notifications+-- from the client, so should not normally be called manually.+requestConfigUpdate :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> m ()+requestConfigUpdate logger = do+  caps <- LspT $ asks resClientCapabilities+  let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just+  if supportsConfiguration+  then do+    section <- LspT $ asks resConfigSection+    void $ sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case+      Right [newConfigObject] -> tryChangeConfig logger newConfigObject+      Right sections -> logger <& WrongConfigSections sections `WithSeverity` Error+      Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error+  else+    logger <& ConfigurationNotSupported `WithSeverity` Debug++{- Note [LSP configuration]+LSP configuration is a huge mess.+- The configuration model of the client is not specified+- Many of the configuration messages are not specified in what they should return++In particular, configuration appears in three places:+1. The `initializationOptions` field of the `initialize` request.+  - The contents of this are unspecified. "User provided initialization options".+2. The `settings` field of the `workspace/didChangeConfiguration` notification.+  - The contents of this are unspecified. "The actual changed settings".+3. The `section` field of the response to the `workspace/configuration` request.+  - This at least says it should be the settings corresponding to the sections+    specified in the request.++It's very hard to know what to do here. In particular, the first two cases seem+like they could include arbitrary configuration from the client that might not+relate to you. How you locate "your" settings is unclear.++We are on firmer ground with case 3. Then at least it seems that we can pick+a configuration section, just always ask for that, and require clients to use+that for our settings. Furthermore, this is the method that is encouraged by the+specification designers: https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-420589320.++For this reason we mostly try and rely on `workspace/configuration`. That means+three things:+- We require servers to give a specific configuration section for us to use+  when requesting configuration.+- We can try and make sense of `initializationOptions`, but regardless we should+  send a `workspace/configuration` request afterwards (in the handler for the+  `initialized` notification, which is the earliest we can send messages:+  https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-953772465)+- We can try and make sense of `didChangeConfiguration`, but regardless we should+  send a `workspace/configuration` request afterwards++We do try to make sense of the first two cases also, especially because clients do+not have to support `workspace/configuration`! In practice,+many clients seem to follow the sensible approach laid out here:+https://github.com/microsoft/language-server-protocol/issues/972#issuecomment-626668243++To make this work, we try to be tolerant by using the following strategy.+When we receive a configuration object from any of the sources above, we first+check to see if it has a field corresponding to our configuration section. If it+does, then we assume that it our config and try to parse it. If it does not, we+try to parse the entire config object. This hopefully lets us handle a variety+of sensible cases where the client sends us mostly our config, either wrapped+in our section or not.+-}

@@ -1,15 +1,16 @@-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE RecursiveDo         #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeInType          #-}  {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- there's just so much!@@ -20,48 +21,54 @@  module Language.LSP.Server.Processing where -import           Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))+import           Colog.Core                             (LogAction (..),+                                                         Severity (..),+                                                         WithSeverity (..),+                                                         cmap, (<&)) -import           Control.Lens hiding (Empty)-import           Data.Aeson hiding (Options, Error, Null)-import           Data.Aeson.Types hiding (Options, Error, Null)-import qualified Data.ByteString.Lazy as BSL-import           Data.List-import Data.List.NonEmpty (NonEmpty(..))-import           Data.Row-import qualified Data.Text as T-import qualified Data.Text.Lazy.Encoding as TL-import qualified Language.LSP.Protocol.Lens as L-import           Language.LSP.Protocol.Types-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)-import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap-import           Language.LSP.Server.Core-import           Language.LSP.VFS as VFS-import qualified Data.Functor.Product as P-import qualified Control.Exception as E-import           Data.Monoid +import           Control.Concurrent.STM+import qualified Control.Exception                      as E+import           Control.Lens                           hiding (Empty) import           Control.Monad+import           Control.Monad.Except                   () import           Control.Monad.IO.Class-import           Control.Monad.Except ()-import           Control.Concurrent.STM-import           Control.Monad.Trans.Except import           Control.Monad.Reader+import           Control.Monad.State+import           Control.Monad.Trans.Except+import           Control.Monad.Writer.Strict+import           Data.Aeson                             hiding (Error, Null,+                                                         Options)+import           Data.Aeson.Lens                        ()+import           Data.Aeson.Types                       hiding (Error, Null,+                                                         Options)+import qualified Data.ByteString.Lazy                   as BSL+import           Data.Foldable                          (traverse_)+import qualified Data.Functor.Product                   as P import           Data.IxMap+import           Data.List+import           Data.List.NonEmpty                     (NonEmpty (..))+import qualified Data.Map.Strict                        as Map import           Data.Maybe-import qualified Data.Map.Strict as Map+import           Data.Monoid+import           Data.Row+import           Data.String                            (fromString)+import qualified Data.Text                              as T+import qualified Data.Text.Lazy.Encoding                as TL import           Data.Text.Prettyprint.Doc+import qualified Language.LSP.Protocol.Lens             as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)+import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap+import           Language.LSP.Server.Core+import           Language.LSP.VFS                       as VFS import           System.Exit-import           GHC.TypeLits (symbolVal)-import           Control.Monad.State-import           Control.Monad.Writer.Strict -import           Data.Foldable (traverse_)  data LspProcessingLog =   VfsLog VfsLog+  | LspCore LspCoreLog   | MessageProcessingError BSL.ByteString String   | forall m . MissingHandler Bool (SClientMethod m)-  | ConfigurationParseError Value T.Text   | ProgressCancel ProgressToken   | Exiting @@ -69,6 +76,7 @@  instance Pretty LspProcessingLog where   pretty (VfsLog l) = pretty l+  pretty (LspCore l) = pretty l   pretty (MessageProcessingError bs err) =     vsep [       "LSP: incoming message parse error:"@@ -76,15 +84,8 @@       , "when processing"       , pretty (TL.decodeUtf8 bs)       ]-  pretty (MissingHandler _ m) = "LSP: no handler for:" <+> viaShow m-  pretty (ConfigurationParseError settings err) =-    vsep [-      "LSP: configuration parse error:"-      , pretty err-      , "when parsing"-      , viaShow settings-      ]-  pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> viaShow tid+  pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m+  pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid   pretty Exiting = "LSP: Got exit, exiting"  processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m ()@@ -110,12 +111,13 @@  -- | Call this to initialize the session initializeRequestHandler-  :: ServerDefinition config+  :: LogAction IO (WithSeverity LspProcessingLog)+  -> ServerDefinition config   -> VFS   -> (FromServerMessage -> IO ())   -> TMessage Method_Initialize   -> IO (Maybe (LanguageContextEnv config))-initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do+initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do   let sendResp = sendFunc . FromServerRsp SMethod_Initialize       handleErr (Left err) = do         sendResp $ makeResponseError (req ^. L.id) err@@ -130,12 +132,20 @@      let initialWfs = case p ^. L.workspaceFolders of           Just (InL xs) -> xs-          _ -> []+          _             -> [] -        initialConfig = case onConfigurationChange defaultConfig <$> (p ^. L.initializationOptions) of-          Just (Right newConfig) -> newConfig-          _ -> defaultConfig+        -- See Note [LSP configuration]+        configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) +    initialConfig <- case configObject of+      Just o -> case parseConfig defaultConfig o of+          Right newConfig -> pure newConfig+          Left err -> do+            -- Warn not error here, since initializationOptions is pretty unspecified+            liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning+            pure defaultConfig+      Nothing -> pure defaultConfig+     stateVars <- liftIO $ do       resVFS              <- newTVarIO (VFSData vfs mempty)       resDiagnostics      <- newTVarIO mempty@@ -152,7 +162,8 @@       pure LanguageContextState{..}      -- Call the 'duringInitialization' callback to let the server kick stuff up-    let env = LanguageContextEnv handlers onConfigurationChange sendFunc stateVars (p ^. L.capabilities) rootDir+    let env = LanguageContextEnv handlers configSection parseConfig configChanger sendFunc stateVars (p ^. L.capabilities) rootDir+        configChanger config = forward interpreter (onConfigChange config)         handlers = transmuteHandlers interpreter (staticHandlers clientCaps)         interpreter = interpretHandler initializationResult     initializationResult <- ExceptT $ doInitialize env req@@ -235,8 +246,8 @@      supported_b :: forall m. SClientMethod m -> Bool     supported_b m = case splitClientMethod m of-      IsClientNot -> SMethodMap.member m $ notHandlers h-      IsClientReq -> SMethodMap.member m $ reqHandlers h+      IsClientNot    -> SMethodMap.member m $ notHandlers h+      IsClientReq    -> SMethodMap.member m $ reqHandlers h       IsClientEither -> error "capabilities depend on custom method"      singleton :: a -> [a]@@ -316,7 +327,7 @@       | otherwise = Nothing      sync = case optTextDocumentSync o of-            Just x -> Just (InL x)+            Just x  -> Just (InL x)             Nothing -> Nothing      workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing@@ -330,7 +341,9 @@ handle logger m msg =   case m of     SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg-    SMethod_WorkspaceDidChangeConfiguration    -> handle' logger (Just $ handleConfigChange logger) m msg+    SMethod_WorkspaceDidChangeConfiguration    -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg+    -- See Note [LSP configuration]+    SMethod_Initialized                        -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg     SMethod_TextDocumentDidOpen                -> handle' logger (Just $ vfsFunc logger openVFS) m msg     SMethod_TextDocumentDidChange              -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg     SMethod_TextDocumentDidClose               -> handle' logger (Just $ vfsFunc logger closeVFS) m msg@@ -382,7 +395,7 @@      IsClientEither -> case msg of       NotMess noti -> case pickHandler dynNotHandlers notHandlers of-        Just h -> liftIO $ h noti+        Just h  -> liftIO $ h noti         Nothing -> reportMissingHandler       ReqMess req -> case pickHandler dynReqHandlers reqHandlers of         Just h -> liftIO $ h req (mkRspCb req)@@ -397,8 +410,8 @@     pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth)     pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of       (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h-      (Nothing, Just (ClientMessageHandler h)) -> Just h-      (Nothing, Nothing) -> Nothing+      (Nothing, Just (ClientMessageHandler h))      -> Just h+      (Nothing, Nothing)                            -> Nothing      -- '$/' notifications should/could be ignored by server.     -- Don't log errors in that case.@@ -427,17 +440,29 @@ shutdownRequestHandler _req k = do   k $ Right Null -handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m ()-handleConfigChange logger req = do-  parseConfig <- LspT $ asks resParseConfig-  let s = req ^. L.params . L.settings-  res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig s of-    Left err -> (Left err, oldConfig)-    Right !newConfig -> (Right (), newConfig)-  case res of-    Left err -> do-      logger <& ConfigurationParseError s err `WithSeverity` Error-    Right () -> pure ()+-- | Try to find the configuration section in an object that might represent "all" the settings.+-- The heuristic we use is to look for a property with the right name, and use that if we find+-- it. Otherwise we fall back to the whole object.+-- See Note [LSP configuration]+lookForConfigSection :: T.Text -> Value -> Value+lookForConfigSection section (Object o) | Just s' <- o ^. at (fromString $ T.unpack section) = s'+lookForConfigSection _ o = o++-- | Handle a workspace/didChangeConfiguration request.+handleDidChangeConfiguration :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m ()+handleDidChangeConfiguration logger req = do+  section <- LspT $ asks resConfigSection+  -- See Note [LSP configuration]++  -- There are a few cases:+  -- 1. Client supports `workspace/configuration` and sends nothing in `workspace/didChangeConfiguration`+  --    Then we will fail the first attempt and succeed the second one.+  -- 2. Client does not support `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`.+  --    Then we will succeed the first attempt and fail (or in fact do nothing in) the second one.+  -- 3. Client supports `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`.+  --    Then both will succeed, which is a bit redundant but not a big deal.+  tryChangeConfig (cmap (fmap LspCore) logger) (lookForConfigSection section $ req ^. L.params . L.settings)+  requestConfigUpdate (cmap (fmap LspCore) logger)  vfsFunc :: forall m n a config         . (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS))

@@ -126,13 +126,13 @@ instance Pretty VfsLog where   pretty (SplitInsideCodePoint pos r) =     "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r-  pretty (URINotFound uri) = "VFS: don't know about URI" <+> viaShow uri-  pretty (Opening uri) = "VFS: opening" <+> viaShow uri-  pretty (Closing uri) = "VFS: closing" <+> viaShow uri-  pretty (PersistingFile uri fp) = "VFS: Writing virtual file for" <+> viaShow uri <+> "to" <+> viaShow fp+  pretty (URINotFound uri) = "VFS: don't know about URI" <+> pretty uri+  pretty (Opening uri) = "VFS: opening" <+> pretty uri+  pretty (Closing uri) = "VFS: closing" <+> pretty uri+  pretty (PersistingFile uri fp) = "VFS: Writing virtual file for" <+> pretty uri <+> "to" <+> viaShow fp   pretty (CantRecursiveDelete uri) =-    "VFS: can't recursively delete" <+> viaShow uri <+> "because we don't track directory status"-  pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> viaShow uri+    "VFS: can't recursively delete" <+> pretty uri <+> "because we don't track directory status"+  pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> pretty uri  makeFieldsNoPrefix ''VirtualFile makeFieldsNoPrefix ''VFS