diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 7f13a5e5..2c2d26fb 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -1,65 +1,69 @@ +{-# 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 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 (..), Severity (..), (<&)) +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 L -import qualified Language.LSP.Protocol.Lens as L -import qualified Language.LSP.Protocol.Message as L +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.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 Prettyprinter +import System.Random hiding (next) -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -122,15 +126,15 @@ instance MonadLsp c m => MonadLsp c (IdentityT m) where data LanguageContextEnv config = LanguageContextEnv - { resHandlers :: !(Handlers IO) - , resConfigSection :: T.Text - , resParseConfig :: !(config -> J.Value -> Either T.Text config) - , resOnConfigChange :: !(config -> IO ()) - , 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 :: !L.ClientCapabilities - , resRootPath :: !(Maybe FilePath) + , resState :: !(LanguageContextState config) + , resClientCapabilities :: !L.ClientCapabilities + , resRootPath :: !(Maybe FilePath) } -- --------------------------------------------------------------------- @@ -175,7 +179,7 @@ type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) -- | 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 } @@ -194,15 +198,15 @@ mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' -- | 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) @@ -218,7 +222,7 @@ data ProgressData = ProgressData { progressNextId :: !(TVar Int32) data VFSData = VFSData - { vfsData :: !VFS + { vfsData :: !VFS , reverseMap :: !(Map.Map FilePath FilePath) } @@ -315,16 +319,17 @@ data ServerDefinition config = forall m a. -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we -- get updated configuration from the client. -- - -- @parseConfig@ is called on the object corresponding to the config section, it should - -- not itself try to look for the config section. + -- @parseConfig@ is called on the object corresponding to the server's + -- config section, it should not itself try to look for the config section. -- - -- @parseConfig@ also receives the old configuration. This is only useful when parsing - -- changed settings from @workspace/didChangeConfiguration@ requests where the client - -- sends only the changed settings. However, this behaviour is discouraged, so in future - -- @parseConfig@ may change to only take a full new config object. + -- 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. -- - -- @parseConfig@ should return either the parsed configuration data or an error - -- indicating what went wrong. , 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 @@ -383,7 +388,7 @@ sendNotification 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 @@ -399,7 +404,7 @@ sendRequest m params resHandler = do 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 @@ -437,7 +442,7 @@ persistVirtualFile logger uri = do 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 @@ -451,7 +456,7 @@ getVersionedTextDoc doc = do mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of Just (VirtualFile lspver _ _) -> lspver - Nothing -> 0 + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) {-# INLINE getVersionedTextDoc #-} @@ -535,8 +540,8 @@ registerCapability method regOpts f = do 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 @@ -611,8 +616,8 @@ registerCapability method regOpts f = do 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 = L.TUnregistration uuid m @@ -651,7 +656,7 @@ withProgressBase indefinite title cancellable f = do | indefinite = Nothing | otherwise = Just 0 cancellable' = case cancellable of - Cancellable -> True + Cancellable -> True NotCancellable -> False -- Create progress token @@ -663,7 +668,7 @@ withProgressBase indefinite title cancellable f = do -- 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 -> @@ -790,8 +795,8 @@ tryChangeConfig :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> 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) + Left err -> (Left err, oldConfig) + Right newConfig -> (Right newConfig, newConfig) case res of Left err -> do logger <& ConfigurationParseError newConfigObject err `WithSeverity` Warning @@ -811,11 +816,10 @@ requestConfigUpdate logger = do if supportsConfiguration then do section <- LspT $ asks resConfigSection - _ <- sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case + 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 - pure () else logger <& ConfigurationNotSupported `WithSeverity` Debug diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index 021ecb0d..48c457ad 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -1,16 +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 LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeInType #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- there's just so much! @@ -21,43 +21,48 @@ module Language.LSP.Server.Processing where -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&), cmap) +import Colog.Core (LogAction (..), + Severity (..), + WithSeverity (..), + cmap, (<&)) -import Control.Lens hiding (Empty) -import Data.Aeson.Lens () -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 Control.Monad.State -import Control.Monad.Writer.Strict -import Data.Foldable (traverse_) -import Data.String (fromString) data LspProcessingLog = VfsLog VfsLog @@ -127,7 +132,7 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do let initialWfs = case p ^. L.workspaceFolders of Just (InL xs) -> xs - _ -> [] + _ -> [] -- See Note [LSP configuration] configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) @@ -241,8 +246,8 @@ inferServerCapabilities clientCaps o h = 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] @@ -322,7 +327,7 @@ inferServerCapabilities clientCaps o h = | otherwise = Nothing sync = case optTextDocumentSync o of - Just x -> Just (InL x) + Just x -> Just (InL x) Nothing -> Nothing workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing @@ -390,7 +395,7 @@ handle' logger mAction m msg = do 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) @@ -405,8 +410,8 @@ handle' logger mAction m msg = do 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. @@ -447,8 +452,16 @@ lookForConfigSection _ o = o handleDidChangeConfiguration :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m () handleDidChangeConfiguration logger req = do section <- LspT $ asks resConfigSection - tryChangeConfig (cmap (fmap LspCore) logger) (lookForConfigSection section $ req ^. L.params . L.settings) -- 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