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'