From bce18bcd344988e7e75990ff75ad1cb03be65f70 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 12 May 2020 16:37:21 +0100 Subject: [PATCH] Hide LSP ids from the users This changes the send function into two separate functions, where parameters are passed instead of raw messages. That way haskell-lsp can do the bookkeeping work of figuring out the appropriate request id, and we can get rid of MessageFuncs since the user no longer needs to construct messages from scratch. --- haskell-lsp-types/haskell-lsp-types.cabal | 1 - .../src/Language/Haskell/LSP/Types/Message.hs | 5 +- .../Haskell/LSP/Types/MessageFuncs.hs | 344 ------------------ .../src/Language/Haskell/LSP/Types/Uri.hs | 6 +- src/Language/Haskell/LSP/Core.hs | 143 ++++---- 5 files changed, 73 insertions(+), 426 deletions(-) delete mode 100644 haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index 4e83d62c7..aa4c544ef 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -21,7 +21,6 @@ library , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Types.Constants , Language.Haskell.LSP.Types.Lens - , Language.Haskell.LSP.Types.MessageFuncs , Language.Haskell.LSP.Types.Utils , Data.IxMap other-modules: Language.Haskell.LSP.Types.ClientCapabilities diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index dac55fadc..a169faad8 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -235,6 +235,8 @@ instance (ToJSON (MessageParams m), FromJSON (SMethod m)) => ToJSON (RequestMess toJSON = genericToJSON lspOptions toEncoding = genericToEncoding lspOptions +-- | A custom message data type is needed to distinguish between +-- notifications and requests, since a CustomMethod can be both! data CustomMessage p t where ReqMess :: RequestMessage (CustomMethod :: Method p Request) -> CustomMessage p Request NotMess :: NotificationMessage (CustomMethod :: Method p Notification) -> CustomMessage p Notification @@ -421,10 +423,7 @@ type HandlerFunc a = Either ResponseError a -> IO () -- () for Notifications -- This is a callback that will be invoked when your request -- recieves a response --- Custom methods can either be a notification or a request, so --- it may or may not have a response handler! type family ResponseHandlerFunc m :: Type where - ResponseHandlerFunc CustomMethod = Maybe (HandlerFunc Value) ResponseHandlerFunc (m :: Method p t) = BaseHandlerFunc t m type family BaseHandlerFunc (t :: MethodType) (m :: Method p t) :: Type where diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs deleted file mode 100644 index fcc4f0e95..000000000 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - -module Language.Haskell.LSP.Types.MessageFuncs ( - -- * General - fmClientInitializeRequest - , fmClientInitializedNotification - , fmClientShutdownRequest - , fmClientExitNotification - , fmClientCancelNotification - - -- * Window - , fmServerShowMessageNotification - , fmServerShowMessageRequest - , fmServerLogMessageNotification - , fmServerWorkDoneProgressBeginNotification - , fmServerWorkDoneProgressReportNotification - , fmServerWorkDoneProgressEndNotification - , fmServerWorkDoneProgressCreateRequest - , fmServerTelemetryNotification - - -- * Client - , fmServerRegisterCapabilityRequest - , fmServerUnregisterCapabilityRequest - - -- * Workspace - , fmClientDidChangeConfigurationNotification - , fmClientDidChangeWatchedFilesNotification - , fmClientWorkspaceSymbolRequest - , fmClientExecuteCommandRequest - , fmServerApplyWorkspaceEditRequest - - -- * Document - , fmServerPublishDiagnosticsNotification - , fmClientDidOpenTextDocumentNotification - , fmClientDidChangeTextDocumentNotification - , fmClientWillSaveTextDocumentNotification - , fmClientWillSaveWaitUntilRequest - , fmClientDidSaveTextDocumentNotification - , fmClientDidCloseTextDocumentNotification - , fmClientCompletionRequest - , fmClientCompletionItemResolveRequest - , fmClientHoverRequest - , fmClientSignatureHelpRequest - , fmClientReferencesRequest - , fmClientDocumentHighlightRequest - , fmClientDocumentSymbolRequest - , fmClientDocumentFormattingRequest - , fmClientDocumentRangeFormattingRequest - , fmClientDocumentOnTypeFormattingRequest - , fmClientDefinitionRequest - , fmClientCodeActionRequest - , fmClientCodeLensRequest - , fmClientCodeLensResolveRequest - , fmClientDocumentLinkRequest - , fmClientDocumentLinkResolveRequest - , fmClientRenameRequest - , fmClientPrepareRenameRequest - ) where - -import qualified Data.Aeson as J -import Data.Text ( Text ) -import qualified Language.Haskell.LSP.Types as J - --- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} --- --------------------------------------------------------------------- - --- ---------------------------------------------------------------------- --- General --- ---------------------------------------------------------------------- - --- * :leftwards_arrow_with_hook: [initialize](#initialize) - -fmClientInitializeRequest :: J.LspId J.Initialize -> J.InitializeParams -> J.InitializeRequest -fmClientInitializeRequest rid params - = J.RequestMessage "2.0" rid J.SInitialize params - --- ---------------------------------------------------------------------- --- * **New** :arrow_right: [initialized](#initialized) - --- | From 3.0 -fmClientInitializedNotification :: J.InitializedNotification -fmClientInitializedNotification = J.NotificationMessage "2.0" J.SInitialized Nothing - --- ---------------------------------------------------------------------- --- * :leftwards_arrow_with_hook: [shutdown](#shutdown) - -fmClientShutdownRequest :: J.LspId J.Shutdown -> Maybe J.Value -> J.ShutdownRequest -fmClientShutdownRequest rid params - = J.RequestMessage "2.0" rid J.SShutdown params - --- ---------------------------------------------------------------------- --- * :arrow_right: [exit](#exit) - -fmClientExitNotification :: J.ExitNotification -fmClientExitNotification = J.NotificationMessage "2.0" J.SExit Nothing - --- ---------------------------------------------------------------------- --- * :arrow_right: [$/cancelRequest](#cancelRequest) - -fmClientCancelNotification :: J.LspId a -> J.CancelNotification -fmClientCancelNotification idToCancel - = J.NotificationMessage "2.0" J.SCancelRequest (J.CancelParams idToCancel) - --- ---------------------------------------------------------------------- --- Window --- ---------------------------------------------------------------------- - --- * :arrow_left: [window/showMessage](#window_showMessage) - -fmServerShowMessageNotification :: J.MessageType -> Text -> J.ShowMessageNotification -fmServerShowMessageNotification mt msg - = J.NotificationMessage "2.0" J.SWindowShowMessage (J.ShowMessageParams mt msg) - --- ---------------------------------------------------------------------- --- * :arrow_right_hook: [window/showMessageRequest](#window_showMessageRequest) - -fmServerShowMessageRequest :: J.LspId J.WindowShowMessageRequest -> J.ShowMessageRequestParams -> J.ShowMessageRequest -fmServerShowMessageRequest rid params - = J.RequestMessage "2.0" rid J.SWindowShowMessageRequest params - --- ---------------------------------------------------------------------- --- * :arrow_left: [window/logMessage](#window_logMessage) - -fmServerLogMessageNotification :: J.MessageType -> Text -> J.LogMessageNotification -fmServerLogMessageNotification mt msg - = J.NotificationMessage "2.0" J.SWindowLogMessage (J.LogMessageParams mt msg) - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressBeginNotification :: J.ProgressParams J.WorkDoneProgressBeginParams -> J.ProgressNotification -fmServerWorkDoneProgressBeginNotification params - = J.NotificationMessage "2.0" J.SProgress (J.Begin <$> params) - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressReportNotification :: J.ProgressParams J.WorkDoneProgressReportParams -> J.ProgressNotification -fmServerWorkDoneProgressReportNotification params - = J.NotificationMessage "2.0" J.SProgress (J.Report <$> params) - --- ---------------------------------------------------------------------- - -fmServerWorkDoneProgressEndNotification :: J.ProgressParams J.WorkDoneProgressEndParams -> J.ProgressNotification -fmServerWorkDoneProgressEndNotification params - = J.NotificationMessage "2.0" J.SProgress (J.End <$> params) - -fmServerWorkDoneProgressCreateRequest :: J.LspId J.WindowWorkDoneProgressCreate -> J.WorkDoneProgressCreateParams -> J.WindowWorkDoneProgressCreateRequest -fmServerWorkDoneProgressCreateRequest rid params - = J.RequestMessage "2.0" rid J.SWindowWorkDoneProgressCreate params - --- ---------------------------------------------------------------------- --- * :arrow_left: [telemetry/event](#telemetry_event) - -fmServerTelemetryNotification :: J.Value -> J.TelemetryNotification -fmServerTelemetryNotification params - = J.NotificationMessage "2.0" J.STelemetryEvent params - --- ---------------------------------------------------------------------- --- Client --- ---------------------------------------------------------------------- - --- * :arrow_right_hook: [client/registerCapability](#client_registerCapability) --- | from 3.0 -fmServerRegisterCapabilityRequest :: J.LspId J.ClientRegisterCapability -> J.RegistrationParams -> J.RegisterCapabilityRequest -fmServerRegisterCapabilityRequest rid params - = J.RequestMessage "2.0" rid J.SClientRegisterCapability params - --- * :arrow_right_hook: [client/unregisterCapability](#client_unregisterCapability) --- | from 3.0 -fmServerUnregisterCapabilityRequest :: J.LspId J.ClientUnregisterCapability -> J.UnregistrationParams -> J.UnregisterCapabilityRequest -fmServerUnregisterCapabilityRequest rid params - = J.RequestMessage "2.0" rid J.SClientUnregisterCapability params - --- ---------------------------------------------------------------------- --- Workspace --- ---------------------------------------------------------------------- - --- * :arrow_right: [workspace/didChangeConfiguration](#workspace_didChangeConfiguration) -fmClientDidChangeConfigurationNotification :: J.DidChangeConfigurationParams -> J.DidChangeConfigurationNotification -fmClientDidChangeConfigurationNotification params - = J.NotificationMessage "2.0" J.SWorkspaceDidChangeConfiguration params - --- * :arrow_right: [workspace/didChangeWatchedFiles](#workspace_didChangeWatchedFiles) -fmClientDidChangeWatchedFilesNotification :: J.DidChangeWatchedFilesParams -> J.DidChangeWatchedFilesNotification -fmClientDidChangeWatchedFilesNotification params - = J.NotificationMessage "2.0" J.SWorkspaceDidChangeWatchedFiles params - --- * :leftwards_arrow_with_hook: [workspace/symbol](#workspace_symbol) -fmClientWorkspaceSymbolRequest :: J.LspId J.WorkspaceSymbol -> J.WorkspaceSymbolParams -> J.WorkspaceSymbolRequest -fmClientWorkspaceSymbolRequest rid params - = J.RequestMessage "2.0" rid J.SWorkspaceSymbol params - --- * **New** :leftwards_arrow_with_hook: [workspace/executeCommand](#workspace_executeCommand) --- | From 3.0 -fmClientExecuteCommandRequest :: J.LspId J.WorkspaceExecuteCommand -> J.ExecuteCommandParams -> J.ExecuteCommandRequest -fmClientExecuteCommandRequest rid params - = J.RequestMessage "2.0" rid J.SWorkspaceExecuteCommand params - --- * **New** :arrow_right_hook: [workspace/applyEdit](#workspace_applyEdit) --- | From 3.0 -fmServerApplyWorkspaceEditRequest :: J.LspId J.WorkspaceApplyEdit -> J.ApplyWorkspaceEditParams -> J.ApplyWorkspaceEditRequest -fmServerApplyWorkspaceEditRequest rid params - = J.RequestMessage "2.0" rid J.SWorkspaceApplyEdit params - --- ---------------------------------------------------------------------- - -- Document --- ---------------------------------------------------------------------- - --- * :arrow_left: [textDocument/publishDiagnostics](#textDocument_publishDiagnostics) -fmServerPublishDiagnosticsNotification :: J.PublishDiagnosticsParams -> J.PublishDiagnosticsNotification -fmServerPublishDiagnosticsNotification params - = J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params - --- * :arrow_right: [textDocument/didOpen](#textDocument_didOpen) -fmClientDidOpenTextDocumentNotification :: J.DidOpenTextDocumentParams -> J.DidOpenTextDocumentNotification -fmClientDidOpenTextDocumentNotification params - = J.NotificationMessage "2.0" J.STextDocumentDidOpen params - --- * :arrow_right: [textDocument/didChange](#textDocument_didChange) -fmClientDidChangeTextDocumentNotification :: J.DidChangeTextDocumentParams -> J.DidChangeTextDocumentNotification -fmClientDidChangeTextDocumentNotification params - = J.NotificationMessage "2.0" J.STextDocumentDidChange params - --- * :arrow_right: [textDocument/willSave](#textDocument_willSave) -fmClientWillSaveTextDocumentNotification :: J.WillSaveTextDocumentParams -> J.WillSaveTextDocumentNotification -fmClientWillSaveTextDocumentNotification params - = J.NotificationMessage "2.0" J.STextDocumentWillSave params - --- * **New** :leftwards_arrow_with_hook: [textDocument/willSaveWaitUntil](#textDocument_willSaveWaitUntil) --- | From 3.0 -fmClientWillSaveWaitUntilRequest :: J.LspId J.TextDocumentWillSaveWaitUntil -> J.WillSaveTextDocumentParams -> J.WillSaveWaitUntilTextDocumentRequest -fmClientWillSaveWaitUntilRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentWillSaveWaitUntil params - --- * **New** :arrow_right: [textDocument/didSave](#textDocument_didSave) --- | 3.0 -fmClientDidSaveTextDocumentNotification :: J.DidSaveTextDocumentParams -> J.DidSaveTextDocumentNotification -fmClientDidSaveTextDocumentNotification params - = J.NotificationMessage "2.0" J.STextDocumentDidSave params - --- * :arrow_right: [textDocument/didClose](#textDocument_didClose) -fmClientDidCloseTextDocumentNotification :: J.DidCloseTextDocumentParams -> J.DidCloseTextDocumentNotification -fmClientDidCloseTextDocumentNotification params - = J.NotificationMessage "2.0" J.STextDocumentDidClose params - --- * :leftwards_arrow_with_hook: [textDocument/completion](#textDocument_completion) -fmClientCompletionRequest :: J.LspId J.TextDocumentCompletion -> J.CompletionParams -> J.CompletionRequest -fmClientCompletionRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentCompletion params - --- * :leftwards_arrow_with_hook: [completionItem/resolve](#completionItem_resolve) -fmClientCompletionItemResolveRequest :: J.LspId J.CompletionItemResolve -> J.CompletionItem -> J.CompletionItemResolveRequest -fmClientCompletionItemResolveRequest rid params - = J.RequestMessage "2.0" rid J.SCompletionItemResolve params - --- * :leftwards_arrow_with_hook: [textDocument/hover](#textDocument_hover) -fmClientHoverRequest :: J.LspId J.TextDocumentHover -> J.TextDocumentPositionParams -> J.HoverRequest -fmClientHoverRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentHover params - --- * :leftwards_arrow_with_hook: [textDocument/signatureHelp](#textDocument_signatureHelp) -fmClientSignatureHelpRequest :: J.LspId J.TextDocumentSignatureHelp -> J.TextDocumentPositionParams -> J.SignatureHelpRequest -fmClientSignatureHelpRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentSignatureHelp params - --- * :leftwards_arrow_with_hook: [textDocument/references](#textDocument_references) -fmClientReferencesRequest :: J.LspId J.TextDocumentReferences -> J.ReferenceParams -> J.ReferencesRequest -fmClientReferencesRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentReferences params - --- * :leftwards_arrow_with_hook: [textDocument/documentHighlight](#textDocument_documentHighlight) -fmClientDocumentHighlightRequest :: J.LspId J.TextDocumentDocumentHighlight -> J.TextDocumentPositionParams -> J.DocumentHighlightRequest -fmClientDocumentHighlightRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentDocumentHighlight params - --- * :leftwards_arrow_with_hook: [textDocument/documentSymbol](#textDocument_documentSymbol) -fmClientDocumentSymbolRequest :: J.LspId J.TextDocumentDocumentSymbol -> J.DocumentSymbolParams -> J.DocumentSymbolRequest -fmClientDocumentSymbolRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentDocumentSymbol params - --- * :leftwards_arrow_with_hook: [textDocument/formatting](#textDocument_formatting) -fmClientDocumentFormattingRequest :: J.LspId J.TextDocumentFormatting -> J.DocumentFormattingParams -> J.DocumentFormattingRequest -fmClientDocumentFormattingRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/rangeFormatting](#textDocument_rangeFormatting) -fmClientDocumentRangeFormattingRequest :: J.LspId J.TextDocumentRangeFormatting -> J.DocumentRangeFormattingParams -> J.DocumentRangeFormattingRequest -fmClientDocumentRangeFormattingRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentRangeFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/onTypeFormatting](#textDocument_onTypeFormatting) -fmClientDocumentOnTypeFormattingRequest :: J.LspId J.TextDocumentOnTypeFormatting -> J.DocumentOnTypeFormattingParams -> J.DocumentOnTypeFormattingRequest -fmClientDocumentOnTypeFormattingRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentOnTypeFormatting params - --- * :leftwards_arrow_with_hook: [textDocument/definition](#textDocument_definition) -fmClientDefinitionRequest :: J.LspId J.TextDocumentDefinition -> J.TextDocumentPositionParams -> J.DefinitionRequest -fmClientDefinitionRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentDefinition params - --- * :leftwards_arrow_with_hook: [textDocument/codeAction](#textDocument_codeAction) -fmClientCodeActionRequest :: J.LspId J.TextDocumentCodeAction -> J.CodeActionParams -> J.CodeActionRequest -fmClientCodeActionRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentCodeAction params - --- * :leftwards_arrow_with_hook: [textDocument/codeLens](#textDocument_codeLens) -fmClientCodeLensRequest :: J.LspId J.TextDocumentCodeLens -> J.CodeLensParams -> J.CodeLensRequest -fmClientCodeLensRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentCodeLens params - --- * :leftwards_arrow_with_hook: [codeLens/resolve](#codeLens_resolve) -fmClientCodeLensResolveRequest :: J.LspId J.CodeLensResolve -> J.CodeLens -> J.CodeLensResolveRequest -fmClientCodeLensResolveRequest rid params - = J.RequestMessage "2.0" rid J.SCodeLensResolve params - --- * :leftwards_arrow_with_hook: [textDocument/documentLink](#textDocument_documentLink) -fmClientDocumentLinkRequest :: J.LspId J.TextDocumentDocumentLink -> J.DocumentLinkParams -> J.DocumentLinkRequest -fmClientDocumentLinkRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentDocumentLink params - --- * :leftwards_arrow_with_hook: [documentLink/resolve](#documentLink_resolve) -fmClientDocumentLinkResolveRequest :: J.LspId J.DocumentLinkResolve -> J.DocumentLink -> J.DocumentLinkResolveRequest -fmClientDocumentLinkResolveRequest rid params - = J.RequestMessage "2.0" rid J.SDocumentLinkResolve params - --- * :leftwards_arrow_with_hook: [textDocument/rename](#textDocument_rename) -fmClientRenameRequest :: J.LspId J.TextDocumentRename -> J.RenameParams -> J.RenameRequest -fmClientRenameRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentRename params - --- * :leftwards_arrow_with_hook: [textDocument/prepareRename](#textDocument_prepareRename) -fmClientPrepareRenameRequest :: J.LspId J.TextDocumentPrepareRename -> J.TextDocumentPositionParams -> J.PrepareRenameRequest -fmClientPrepareRenameRequest rid params - = J.RequestMessage "2.0" rid J.STextDocumentPrepareRename params diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs index f2d94ea97..666486e7b 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs @@ -24,7 +24,7 @@ import Control.DeepSeq import qualified Data.Aeson as A import Data.Binary (Binary, Get, put, get) import Data.Hashable -import Data.List (isPrefixOf, stripPrefix) +import Data.List (stripPrefix) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif @@ -112,8 +112,8 @@ platformAdjustFromUriPath systemOS authority srcPath = if systemOS /= windowsOS || null srcPath then srcPath else let firstSegment:rest = (FPP.splitDirectories . tail) srcPath -- Drop leading '/' for absolute Windows paths - drive = if FPW.isDrive firstSegment - then FPW.addTrailingPathSeparator firstSegment + drive = if FPW.isDrive firstSegment + then FPW.addTrailingPathSeparator firstSegment else firstSegment in FPW.joinDrive drive $ FPW.joinPath rest diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 0bbba18e4..76d8011c3 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -25,8 +25,6 @@ module Language.Haskell.LSP.Core ( , Progress(..) , ProgressCancellable(..) , ProgressCancelledException - , ServerMessageFunc - , SomeServerMessageWithResponse(..) , Handlers , Options(..) , ClientResponseHandler(..) @@ -61,7 +59,7 @@ import Data.Monoid hiding (Product) import qualified Data.Text as T import Data.Text ( Text ) import Language.Haskell.LSP.Constant -import Language.Haskell.LSP.Types.MessageFuncs +-- import Language.Haskell.LSP.Types.MessageFuncs import qualified Language.Haskell.LSP.Types.Capabilities as C import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J @@ -175,16 +173,6 @@ instance E.Exception ProgressCancelledException -- @since 0.11.0.0 data ProgressCancellable = Cancellable | NotCancellable -data SomeServerMessageWithResponse where - SomeServerMessageWithResponse - :: (J.ToJSON (J.ServerMessage m)) - => J.SServerMethod m - -> J.ServerMessage m - -> ServerResponseHandler m - -> SomeServerMessageWithResponse - -type ServerMessageFunc = SomeServerMessageWithResponse -> IO () - -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs @@ -192,7 +180,15 @@ data LspFuncs c = , config :: !(IO (Maybe c)) -- ^ Derived from the DidChangeConfigurationNotification message via a -- server-provided function. - , sendFunc :: !ServerMessageFunc + , sendReq :: !(forall m. + J.SServerMethod (m :: J.Method J.FromServer J.Request) + -> J.MessageParams m + -> (J.LspId m -> Either J.ResponseError (J.ResponseParams m) -> IO ()) + -> IO (J.LspId m)) + , sendNot :: !(forall m. + J.SServerMethod (m :: J.Method J.FromServer J.Notification) + -> J.MessageParams m + -> IO ()) , getVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe VirtualFile)) , getVirtualFilesFunc :: !(IO VFS) -- ^ Function to return the 'VirtualFile' associated with a @@ -201,7 +197,6 @@ data LspFuncs c = , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc - , getNextReqId :: !(IO Int) , rootPath :: !(Maybe FilePath) , getWorkspaceFolders :: !(IO (Maybe [J.WorkspaceFolder])) , withProgress :: !(forall a . Text -> ProgressCancellable @@ -251,15 +246,15 @@ newtype ClientResponseHandler (m :: J.Method J.FromClient t) = ClientResponseHan newtype ServerResponseHandler (m :: J.Method J.FromServer t) = ServerResponseHandler (J.ResponseHandlerFunc m) mkClientResponseHandler :: J.SClientMethod m -> J.ClientMessage m -> TVar (LanguageContextData config) -> ClientResponseHandler m -mkClientResponseHandler m cm tvarDat = +mkClientResponseHandler m cm tvarDat = ClientResponseHandler $ case J.splitClientMethod m of - J.IsClientNot -> ClientResponseHandler () - J.IsClientReq -> ClientResponseHandler $ \mrsp -> case mrsp of + J.IsClientNot -> () + J.IsClientReq -> \mrsp -> case mrsp of Left err -> sendErrorResponseE tvarDat m (cm ^. J.id) err Right rsp -> sendToClient tvarDat $ J.FromServerRsp m $ makeResponseMessage (cm ^. J.id) rsp - J.IsClientEither -> ClientResponseHandler $ case cm of - J.NotMess _ -> Nothing - J.ReqMess req -> Just $ \mrsp -> case mrsp of + J.IsClientEither -> case cm of + J.NotMess _ -> () + J.ReqMess req -> \mrsp -> case mrsp of Left err -> sendErrorResponseE tvarDat m (req ^. J.id) err Right rsp -> sendToClient tvarDat $ J.FromServerRsp m $ makeResponseMessage (req ^. J.id) rsp @@ -271,31 +266,33 @@ addResponseHandler tv lid h = atomically $ stateTVar tv $ \ctx@LanguageContextDa Just m -> (True,ctx { resPendingResponses = m}) Nothing -> (False, ctx) -mkServerRequestFunc :: TVar (LanguageContextData config) -> SomeServerMessageWithResponse -> IO () -mkServerRequestFunc tvarDat (SomeServerMessageWithResponse m msg resHandler) = - case J.splitServerMethod m of - J.IsServerNot -> sendToClient tvarDat $ J.fromServerNot msg - J.IsServerReq -> do - success <- addResponseHandler tvarDat (msg ^. J.id) (Pair m resHandler) - if success - then sendToClient tvarDat $ J.fromServerReq msg - else do - let mess = T.pack $ - unwords ["haskell-lsp: could not send FromServer request as id is reused" - , show (msg ^. J.id), show $ J.toJSON msg] - sendErrorLog tvarDat mess - J.IsServerEither -> case msg of - J.NotMess _ -> sendToClient tvarDat $ J.FromServerMess m msg - J.ReqMess req -> do - success <- addResponseHandler tvarDat (req ^. J.id) (Pair m resHandler) - if success - then sendToClient tvarDat $ J.FromServerMess m msg - else do - let mess = T.pack $ - unwords ["haskell-lsp: could not send FromServer request as id is reused" - , show (req ^. J.id), show req] - sendErrorLog tvarDat mess - +mkSendNotFunc :: forall (m :: J.Method J.FromServer J.Notification) config. + TVar (LanguageContextData config) + -> J.SServerMethod m + -> J.MessageParams m + -> IO () +mkSendNotFunc tvarDat m params = + let msg = J.NotificationMessage "2.0" m params + in case J.splitServerMethod m of + J.IsServerNot -> sendToClient tvarDat $ J.fromServerNot msg + J.IsServerEither -> sendToClient tvarDat $ J.FromServerMess m $ J.NotMess msg + +mkSendReqFunc :: forall (m :: J.Method J.FromServer J.Request) config. + TVar (LanguageContextData config) + -> J.SServerMethod m + -> J.MessageParams m + -> (J.LspId m -> Either J.ResponseError (J.ResponseParams m) -> IO ()) + -> IO (J.LspId m) +mkSendReqFunc tvarDat m params resHandler = do + reqId <- J.IdInt <$> freshLspId tvarDat + success <- addResponseHandler tvarDat reqId (Pair m (ServerResponseHandler (resHandler reqId))) + unless success $ error "haskell-lsp: could not send FromServer request as id is reused" + + let msg = J.RequestMessage "2.0" reqId m params + (case J.splitServerMethod m of + J.IsServerReq -> sendToClient tvarDat $ J.fromServerReq msg + J.IsServerEither -> sendToClient tvarDat $ J.FromServerMess m $ J.ReqMess msg) :: IO () + return reqId -- | The Handler type captures a function that receives local read-only state -- 'a', a function to send a reply message once encoded as a ByteString, and a @@ -534,17 +531,12 @@ handleMessage dispatcherProc tvarDat jsonStr = do sendErrorLog tvarDat msg f (Left $ J.ResponseError J.ParseError msg Nothing) J.Success (res :: J.ResponseMessage m) -> f (res ^. J.result) - J.IsServerEither -> case f of - Nothing -> - sendErrorLog tvarDat $ - T.pack $ "haskell-lsp: No handler for " - ++ (show resobj) ++ " with method" ++ (show m) - Just f' -> case J.fromJSON $ J.Object resobj of + J.IsServerEither -> case J.fromJSON $ J.Object resobj of J.Error e -> do let msg = T.pack $ unwords ["haskell-lsp: got error while decoding response:", show e, "in", show resobj] sendErrorLog tvarDat msg - f' (Left $ J.ResponseError J.ParseError msg Nothing) - J.Success (res :: J.ResponseMessage m) -> f' (res ^. J.result) + f (Left $ J.ResponseError J.ParseError msg Nothing) + J.Success (res :: J.ResponseMessage m) -> f (res ^. J.result) -- capability based handlers handle json cmd = do ctx <- readTVarIO tvarDat @@ -577,7 +569,8 @@ sendErrorResponseE sf m origId err = do sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () sendErrorLog tv msg = - sendToClient tv $ J.fromServerNot $ fmServerLogMessageNotification J.MtError msg + sendToClient tv $ J.fromServerNot $ + J.NotificationMessage "2.0" J.SWindowLogMessage (J.LogMessageParams J.MtError msg) -- --------------------------------------------------------------------- @@ -591,6 +584,13 @@ initializeErrorHandler sendResp e = -- -- Handlers +freshLspId :: TVar (LanguageContextData config) -> IO Int +freshLspId tvCtx = atomically $ do + tvId <- resLspId <$> readTVar tvCtx + cid <- readTVar tvId + modifyTVar' tvId (+1) + return cid + -- | -- initializeRequestHandler' @@ -614,7 +614,6 @@ initializeRequestHandler' onStartup mHandler tvarCtx = Handler $ \req rspH@(Clie atomically $ modifyTVar' tvarCtx (\c -> c { resWorkspaceFolders = wfs }) - ctx0 <- readTVarIO tvarCtx let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath , params ^. J.rootPath <&> T.unpack ] @@ -625,11 +624,6 @@ initializeRequestHandler' onStartup mHandler tvarCtx = Handler $ \req rspH@(Clie unless (null dir) $ setCurrentDirectory dir let - getLspId tvId = atomically $ do - cid <- readTVar tvId - modifyTVar' tvId (+1) - return cid - clientSupportsWfs = fromMaybe False $ do let (C.ClientCapabilities mw _ _ _) = params ^. J.capabilities (C.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw @@ -680,25 +674,24 @@ initializeRequestHandler' onStartup mHandler tvarCtx = Handler $ \req rspH@(Clie Cancellable -> True NotCancellable -> False - rId <- getLspId $ resLspId ctx0 + rId <- freshLspId tvarCtx -- Create progress token - liftIO $ sf $ J.fromServerReq $ - fmServerWorkDoneProgressCreateRequest (J.IdInt rId) $ J.WorkDoneProgressCreateParams progId + liftIO $ sf $ J.fromServerReq $ J.RequestMessage + "2.0" (J.IdInt rId) J.SWindowWorkDoneProgressCreate (J.WorkDoneProgressCreateParams progId) -- Send initial notification - liftIO $ sf $ J.fromServerNot $ fmServerWorkDoneProgressBeginNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage + liftIO $ sf $ J.fromServerNot $ J.NotificationMessage "2.0" J.SProgress $ + fmap J.Begin $ J.ProgressParams progId $ + J.WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage aid <- async $ f (updater progId (sf . J.fromServerNot)) storeProgress progId aid res <- wait aid -- Send done notification - liftIO $ sf $ J.fromServerNot $ fmServerWorkDoneProgressEndNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressEndParams Nothing + liftIO $ sf $ J.fromServerNot $ J.NotificationMessage "2.0" J.SProgress $ + J.End <$> (J.ProgressParams progId (J.WorkDoneProgressEndParams Nothing)) -- Delete the progress cancellation from the map -- If we don't do this then it's easy to leak things as the map contains any IO action. deleteProgress progId @@ -707,9 +700,9 @@ initializeRequestHandler' onStartup mHandler tvarCtx = Handler $ \req rspH@(Clie return res | otherwise = f (const $ return ()) where updater progId sf (Progress percentage msg) = - sf $ fmServerWorkDoneProgressReportNotification $ - J.ProgressParams progId $ - J.WorkDoneProgressReportParams Nothing msg percentage + sf $ J.NotificationMessage "2.0" J.SProgress $ + fmap J.Report $ J.ProgressParams progId $ + J.WorkDoneProgressReportParams Nothing msg percentage withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a withProgress' = withProgressBase False @@ -721,14 +714,14 @@ initializeRequestHandler' onStartup mHandler tvarCtx = Handler $ \req rspH@(Clie -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (params ^. J.capabilities) (getConfig tvarCtx) - (mkServerRequestFunc tvarCtx) + (mkSendReqFunc tvarCtx) + (mkSendNotFunc tvarCtx) (getVirtualFile tvarCtx) (getVirtualFiles tvarCtx) (persistVirtualFile tvarCtx) (reverseFileMap tvarCtx) (publishDiagnostics tvarCtx) (flushDiagnosticsBySource tvarCtx) - (getLspId $ resLspId ctx0) rootDir (getWfs tvarCtx) withProgress'