diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for lsp +## 2.7.0.0 -- 2024-06-06 + +- Drop dependency on `uuid` and `random` +- Fix handling of `rootPath` in `intializeParams` +- Update to newer `lsp-types` + ## 2.6.0.0 - Progress reporting now has a configurable start delay and update delay. This allows diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 2.6.0.0 +version: 2.7.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -59,19 +59,18 @@ , base >=4.11 && <5 , bytestring >=0.10 && <0.13 , co-log-core ^>=0.3 - , containers ^>=0.6 + , containers >=0.6 && < 0.8 , data-default ^>=0.7 , directory ^>=1.3 , exceptions ^>=0.10 , extra ^>=1.7 , filepath >=1.4 && < 1.6 , hashable ^>=1.4 - , lens >=5.1 && <5.3 + , lens >=5.1 && <5.4 , lens-aeson ^>=1.2 - , lsp-types ^>=2.2 + , lsp-types ^>=2.3 , mtl >=2.2 && <2.4 , prettyprinter ^>=1.7 - , random ^>=1.2 , sorted-list ^>=0.2.1 , stm ^>=2.5 , text >=1 && <2.2 @@ -80,7 +79,6 @@ , unliftio ^>=0.2 , unliftio-core ^>=0.2 , unordered-containers ^>=0.2 - , uuid >=1.3 executable lsp-demo-reactor-server import: warnings diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -48,7 +48,6 @@ import Data.Ord (Down (Down)) import Data.Text (Text) import Data.Text qualified as T -import Data.UUID qualified as UUID import Language.LSP.Diagnostics import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Lens qualified as L @@ -61,7 +60,6 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.VFS hiding (end) import Prettyprinter -import System.Random hiding (next) -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -76,7 +74,7 @@ NewConfig J.Value | ConfigurationParseError J.Value T.Text | ConfigurationNotSupported - | BadConfigurationResponse ResponseError + | BadConfigurationResponse (TResponseError Method_WorkspaceConfiguration) | WrongConfigSections [J.Value] | forall m. CantRegister (SMethod m) @@ -179,7 +177,7 @@ from the server or client -} type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where - Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f () + Handler f (m :: Method _from Request) = TRequestMessage m -> (Either (TResponseError m) (MessageResult m) -> f ()) -> f () Handler f (m :: Method _from Notification) = TNotificationMessage m -> f () -- | How to convert two isomorphic data structures between each other. @@ -350,7 +348,7 @@ -- 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) + , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) a) -- ^ Called *after* receiving the @initialize@ request and *before* -- returning the response. This callback will be invoked to offer the -- language server implementation the chance to create any processes or @@ -385,7 +383,7 @@ request with either an error, or the response params. -} newtype ServerResponseCallback (m :: Method ServerToClient Request) - = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ()) + = ServerResponseCallback (Either (TResponseError m) (MessageResult m) -> IO ()) {- | Return value signals if response handler was inserted successfully Might fail if the id was already in the map @@ -414,7 +412,7 @@ MonadLsp config f => SServerMethod m -> MessageParams m -> - (Either ResponseError (MessageResult m) -> f ()) -> + (Either (TResponseError m) (MessageResult m) -> f ()) -> f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId @@ -590,10 +588,10 @@ -- First, check to see if the client supports dynamic registration on this method if dynamicRegistrationSupported method clientCaps then do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = L.TRegistration uuid method (Just regOpts) + rid <- T.pack . show <$> freshLspId + let registration = L.TRegistration rid method (Just regOpts) params = L.RegistrationParams [toUntypedRegistration registration] - regId = RegistrationId uuid + regId = RegistrationId rid -- TODO: handle the scenario where this returns an error _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -196,9 +196,9 @@ makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) - initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) + initializeErrorHandler :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a) initializeErrorHandler sendResp e = do - sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing + sendResp $ TResponseError (InR ErrorCodes_InternalError) msg Nothing pure Nothing where msg = T.pack $ unwords ["Error on initialize:", show e] @@ -518,13 +518,13 @@ (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing - sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> m () + sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either (TResponseError m1) (MessageResult m1) -> m () sendResponse req res = sendToClient $ FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) res requestDuringShutdown :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> m () requestDuringShutdown req = do logger <& MessageDuringShutdown m `WithSeverity` Warning - sendResponse req (Left (ResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing)) + sendResponse req (Left (TResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing)) notificationDuringShutdown :: m () notificationDuringShutdown = logger <& MessageDuringShutdown m `WithSeverity` Warning @@ -541,7 +541,7 @@ missingRequestHandler req = do logger <& MissingHandler False m `WithSeverity` Error let errorMsg = T.pack $ unwords ["No handler for: ", show m] - err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing + err = TResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendResponse req (Left err) progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m ()