From 9aeb923c8312381b9bbe80a73681260c86ef6048 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 27 Oct 2019 20:42:08 +0000 Subject: [PATCH 1/4] Start work on reorganizing Core.Options The capabilities should be all infered --- .../Haskell/LSP/Types/DataTypesJSON.hs | 50 +++++++++-- src/Language/Haskell/LSP/Core.hs | 89 ++++++++++++------- 2 files changed, 102 insertions(+), 37 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 9a014df64..29e5e0716 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -211,13 +211,32 @@ interface CompletionOptions { * The characters that trigger completion automatically. */ triggerCharacters?: string[]; + + /** + * The list of all possible characters that commit a completion. This field can be used + * if clients don't support individual commmit characters per completion item. See + * `ClientCapabilities.textDocument.completion.completionItem.commitCharactersSupport`. + * + * If a server provides both `allCommitCharacters` and commit characters on an individual + * completion item the once on the completion item win. + * + * @since 3.2.0 + */ + allCommitCharacters?: string[]; } -} data CompletionOptions = CompletionOptions - { _resolveProvider :: Maybe Bool - , _triggerCharacters :: Maybe [String] + { _resolveProvider :: Maybe Bool + -- | The characters that trigger completion automatically. + , _triggerCharacters :: Maybe [String] + -- | The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commmit characters per completion item. See + -- `_commitCharactersSupport`. + -- Since LSP 3.2.0 + -- @since 0.18.0.0 + , _allCommitCharacters :: Maybe [String] } deriving (Read,Show,Eq) deriveJSON lspOptions {omitNothingFields = True } ''CompletionOptions @@ -232,11 +251,28 @@ interface SignatureHelpOptions { * The characters that trigger signature help automatically. */ triggerCharacters?: string[]; + /** + * List of characters that re-trigger signature help. + * + * These trigger characters are only active when signature help is already showing. All trigger characters + * are also counted as re-trigger characters. + * + * @since 3.15.0 + */ -} data SignatureHelpOptions = SignatureHelpOptions - { _triggerCharacters :: Maybe [String] + { -- | The characters that trigger signature help automatically. + _triggerCharacters :: Maybe [String] + + -- | List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + -- + -- Since LSP 3.15.0 + -- @since 0.18.0.0 + , _retriggerCharacters :: Maybe [String] } deriving (Read,Show,Eq) deriveJSON lspOptions ''SignatureHelpOptions @@ -304,7 +340,7 @@ interface DocumentOnTypeFormattingOptions { data DocumentOnTypeFormattingOptions = DocumentOnTypeFormattingOptions { _firstTriggerCharacter :: Text - , _moreTriggerCharacter :: Maybe [String] + , _moreTriggerCharacter :: Maybe [Text] } deriving (Read,Show,Eq) deriveJSON lspOptions ''DocumentOnTypeFormattingOptions @@ -327,7 +363,7 @@ export interface DocumentLinkOptions { data DocumentLinkOptions = DocumentLinkOptions - { -- |Document links have a resolve provider as well. + { -- | Document links have a resolve provider as well. _resolveProvider :: Maybe Bool } deriving (Show, Read, Eq) @@ -352,7 +388,7 @@ export interface RenameOptions { data RenameOptions = RenameOptionsStatic Bool | RenameOptions - { -- |Renames should be checked and tested before being executed. + { -- | Renames should be checked and tested before being executed. _prepareProvider :: Maybe Bool } deriving (Show, Read, Eq) @@ -673,7 +709,7 @@ deriveJSON lspOptions ''WorkspaceFolderOptions data WorkspaceOptions = WorkspaceOptions - { -- |The server supports workspace folder. Since LSP 3.6 + { -- | The server supports workspace folder. Since LSP 3.6 -- -- @since 0.7.0.0 _workspaceFolders :: Maybe WorkspaceFolderOptions diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index a45d1de03..e48e46452 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -40,6 +40,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import qualified Data.HashMap.Strict as HM import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -101,15 +102,23 @@ data ProgressData = ProgressData { progressNextId :: !Int data Options = Options { textDocumentSync :: Maybe J.TextDocumentSyncOptions - , completionProvider :: Maybe J.CompletionOptions - , signatureHelpProvider :: Maybe J.SignatureHelpOptions - , typeDefinitionProvider :: Maybe J.GotoOptions - , implementationProvider :: Maybe J.GotoOptions - , codeActionProvider :: Maybe J.CodeActionOptions - , codeLensProvider :: Maybe J.CodeLensOptions - , documentOnTypeFormattingProvider :: Maybe J.DocumentOnTypeFormattingOptions - , renameProvider :: Maybe J.RenameOptions - , documentLinkProvider :: Maybe J.DocumentLinkOptions + -- | The characters that trigger completion automatically. + , completionTriggerCharacters :: Maybe [Char] + -- | The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commmit characters per completion item. See + -- `_commitCharactersSupport`. + , completionAllCommitCharacters :: Maybe [Char] + -- | The characters that trigger signature help automatically. + , signatureHelpTriggerCharacters :: Maybe [Char] + -- | List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + , signatureHelpRetriggerCharacters :: Maybe [Char] + -- | CodeActionKinds that this server may return. + -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server + -- may list out every specific kind they provide. + , codeActionKinds :: Maybe [J.CodeActionKind] + , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) , colorProvider :: Maybe J.ColorOptions , foldingRangeProvider :: Maybe J.FoldingRangeOptions , executeCommandProvider :: Maybe J.ExecuteCommandOptions @@ -118,7 +127,6 @@ data Options = instance Default Options where def = Options Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing -- | A function to publish diagnostics. It aggregates all diagnostics pertaining -- to a particular version of a document, by source, and sends a @@ -236,7 +244,7 @@ data Handlers = , colorPresentationHandler :: !(Maybe (Handler J.ColorPresentationRequest)) , documentFormattingHandler :: !(Maybe (Handler J.DocumentFormattingRequest)) , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest)) - , documentTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) + , documentOnTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) , renameHandler :: !(Maybe (Handler J.RenameRequest)) , prepareRenameHandler :: !(Maybe (Handler J.PrepareRenameRequest)) , foldingRangeHandler :: !(Maybe (Handler J.FoldingRangeRequest)) @@ -359,7 +367,7 @@ handlerMap _ h J.TextDocumentDocumentHighlight = hh nop ReqDocumentHighlights handlerMap _ h J.TextDocumentDocumentSymbol = hh nop ReqDocumentSymbols $ documentSymbolHandler h handlerMap _ h J.TextDocumentFormatting = hh nop ReqDocumentFormatting $ documentFormattingHandler h handlerMap _ h J.TextDocumentRangeFormatting = hh nop ReqDocumentRangeFormatting $ documentRangeFormattingHandler h -handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop ReqDocumentOnTypeFormatting $ documentTypeFormattingHandler h +handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop ReqDocumentOnTypeFormatting $ documentOnTypeFormattingHandler h handlerMap _ h J.TextDocumentCodeAction = hh nop ReqCodeAction $ codeActionHandler h handlerMap _ h J.TextDocumentCodeLens = hh nop ReqCodeLens $ codeLensHandler h handlerMap _ h J.CodeLensResolve = hh nop ReqCodeLensResolve $ codeLensResolveHandler h @@ -839,15 +847,36 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori supported (Just _) = Just True supported Nothing = Nothing - -- If a dynamic setting is provided use it, else set a - -- static True if there is a handler. - static (Just d) _ = Just d - static _ (Just _) = Just (J.GotoOptionsStatic True) - static _ Nothing = Nothing - - static' (Just d) (Just _) = Just d - static' _ (Just _) = Just (J.CodeActionOptionsStatic True) - static' _ _ = Nothing + singleton :: a -> [a] + singleton x = [x] + + completionProvider + | isJust $ completionHandler h = Just $ + J.CompletionOptions + (Just $ isJust $ completionResolveHandler h) + (map singleton <$> completionTriggerCharacters o) + (map singleton <$> completionAllCommitCharacters o) + | otherwise = Nothing + + codeActionProvider + | isJust $ codeActionHandler h = Just (J.CodeActionOptions (codeActionKinds o)) + | otherwise = Just (J.CodeActionOptionsStatic False) + + signatureHelpProvider + | isJust $ signatureHelpHandler h = Just $ + J.SignatureHelpOptions + (map singleton <$> signatureHelpTriggerCharacters o) + (map singleton <$> signatureHelpRetriggerCharacters o) + | otherwise = Nothing + + documentOnTypeFormattingProvider + | isJust $ documentOnTypeFormattingHandler h + , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) + | isJust $ documentOnTypeFormattingHandler h + , Nothing <- documentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing sync = case textDocumentSync o of Just x -> Just (J.TDSOptions x) @@ -864,22 +893,22 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori J.InitializeResponseCapabilitiesInner { J._textDocumentSync = sync , J._hoverProvider = supported (hoverHandler h) - , J._completionProvider = completionProvider o - , J._signatureHelpProvider = signatureHelpProvider o + , J._completionProvider = completionProvider + , J._signatureHelpProvider = signatureHelpProvider , J._definitionProvider = supported (definitionHandler h) - , J._typeDefinitionProvider = static (typeDefinitionProvider o) (typeDefinitionHandler h) - , J._implementationProvider = implementationProvider o + , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h + , J._implementationProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h , J._referencesProvider = supported (referencesHandler h) , J._documentHighlightProvider = supported (documentHighlightHandler h) , J._documentSymbolProvider = supported (documentSymbolHandler h) , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) - , J._codeActionProvider = static' (codeActionProvider o) (codeActionHandler h) - , J._codeLensProvider = codeLensProvider o + , J._codeActionProvider = codeActionProvider + , J._codeLensProvider = Just $ J.CodeLensOptions $ supported $ codeLensResolveHandler h , J._documentFormattingProvider = supported (documentFormattingHandler h) , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) - , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o - , J._renameProvider = renameProvider o - , J._documentLinkProvider = documentLinkProvider o + , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider + , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h + , J._documentLinkProvider = Just $ J.DocumentLinkOptions $ Just $ isJust $ documentLinkResolveHandler h , J._colorProvider = colorProvider o , J._foldingRangeProvider = foldingRangeProvider o , J._executeCommandProvider = executeCommandProvider o From 6f6d380a523320fad1aa82ec879faecf257ca9bf Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 27 Oct 2019 20:58:20 +0000 Subject: [PATCH 2/4] Finish inferring the rest of the capabailities Also pull out the logic into its own function --- .../Haskell/LSP/Types/DataTypesJSON.hs | 2 +- src/Language/Haskell/LSP/Core.hs | 179 +++++++++--------- 2 files changed, 94 insertions(+), 87 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 29e5e0716..de9526abc 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -487,7 +487,7 @@ data TextDocumentSyncOptions = -- | Will save wait until requests are sent to the server. , _willSaveWaitUntil :: Maybe Bool - -- |Save notifications are sent to the server. + -- | Save notifications are sent to the server. , _save :: Maybe SaveOptions } deriving (Show, Read, Eq) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index e48e46452..d7d7ca0cf 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -96,9 +96,8 @@ data ProgressData = ProgressData { progressNextId :: !Int -- --------------------------------------------------------------------- --- | Language Server Protocol options supported by the given language server. --- These are automatically turned into capabilities reported to the client --- during initialization. +-- | Language Server Protocol options that the server may configure. +-- If you set handlers for some requests, you may need to set some of these options. data Options = Options { textDocumentSync :: Maybe J.TextDocumentSyncOptions @@ -118,15 +117,17 @@ data Options = -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server -- may list out every specific kind they provide. , codeActionKinds :: Maybe [J.CodeActionKind] + -- | The list of characters that triggers on type formatting. + -- If you set `documentOnTypeFormattingHandler`, you **must** set this. , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) - , colorProvider :: Maybe J.ColorOptions - , foldingRangeProvider :: Maybe J.FoldingRangeOptions - , executeCommandProvider :: Maybe J.ExecuteCommandOptions + -- | The commands to be executed on the server. + -- If you set `executeCommandHandler`, you **must** set this. + , executeCommandCommands :: Maybe [Text] } instance Default Options where def = Options Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing -- | A function to publish diagnostics. It aggregates all diagnostics pertaining -- to a particular version of a document, by source, and sends a @@ -839,88 +840,94 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp Nothing -> do + let capa = serverCapabilities (resOptions ctx) (resHandlers ctx) + -- TODO: wrap this up into a fn to create a response message + res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing - let - h = resHandlers ctx - o = resOptions ctx - - supported (Just _) = Just True - supported Nothing = Nothing - - singleton :: a -> [a] - singleton x = [x] - - completionProvider - | isJust $ completionHandler h = Just $ - J.CompletionOptions - (Just $ isJust $ completionResolveHandler h) - (map singleton <$> completionTriggerCharacters o) - (map singleton <$> completionAllCommitCharacters o) - | otherwise = Nothing - - codeActionProvider - | isJust $ codeActionHandler h = Just (J.CodeActionOptions (codeActionKinds o)) - | otherwise = Just (J.CodeActionOptionsStatic False) - - signatureHelpProvider - | isJust $ signatureHelpHandler h = Just $ - J.SignatureHelpOptions - (map singleton <$> signatureHelpTriggerCharacters o) - (map singleton <$> signatureHelpRetriggerCharacters o) - | otherwise = Nothing - - documentOnTypeFormattingProvider - | isJust $ documentOnTypeFormattingHandler h - , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ - J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) - | isJust $ documentOnTypeFormattingHandler h - , Nothing <- documentOnTypeFormattingTriggerCharacters o = - error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" - | otherwise = Nothing - - sync = case textDocumentSync o of - Just x -> Just (J.TDSOptions x) - Nothing -> Nothing - - workspace = J.WorkspaceOptions workspaceFolder - workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of - Just _ -> Just $ - -- sign up to receive notifications - J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) - Nothing -> Nothing + sendResponse tvarCtx $ RspInitialize res - capa = - J.InitializeResponseCapabilitiesInner - { J._textDocumentSync = sync - , J._hoverProvider = supported (hoverHandler h) - , J._completionProvider = completionProvider - , J._signatureHelpProvider = signatureHelpProvider - , J._definitionProvider = supported (definitionHandler h) - , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h - , J._implementationProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h - , J._referencesProvider = supported (referencesHandler h) - , J._documentHighlightProvider = supported (documentHighlightHandler h) - , J._documentSymbolProvider = supported (documentSymbolHandler h) - , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) - , J._codeActionProvider = codeActionProvider - , J._codeLensProvider = Just $ J.CodeLensOptions $ supported $ codeLensResolveHandler h - , J._documentFormattingProvider = supported (documentFormattingHandler h) - , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) - , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h - , J._documentLinkProvider = Just $ J.DocumentLinkOptions $ Just $ isJust $ documentLinkResolveHandler h - , J._colorProvider = colorProvider o - , J._foldingRangeProvider = foldingRangeProvider o - , J._executeCommandProvider = executeCommandProvider o - , J._workspace = Just workspace - -- TODO: Add something for experimental - , J._experimental = Nothing :: Maybe J.Value - } - - -- TODO: wrap this up into a fn to create a response message - res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing +-- | Infers the capabilities based on register handlers, and sets the appropriate options. +serverCapabilities :: Options -> Handlers -> J.InitializeResponseCapabilitiesInner +serverCapabilities o h = + J.InitializeResponseCapabilitiesInner + { J._textDocumentSync = sync + , J._hoverProvider = supported (hoverHandler h) + , J._completionProvider = completionProvider + , J._signatureHelpProvider = signatureHelpProvider + , J._definitionProvider = supported (definitionHandler h) + , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h + , J._implementationProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h + , J._referencesProvider = supported (referencesHandler h) + , J._documentHighlightProvider = supported (documentHighlightHandler h) + , J._documentSymbolProvider = supported (documentSymbolHandler h) + , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) + , J._codeActionProvider = codeActionProvider + , J._codeLensProvider = Just $ J.CodeLensOptions $ supported $ codeLensResolveHandler h + , J._documentFormattingProvider = supported (documentFormattingHandler h) + , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) + , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider + , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h + , J._documentLinkProvider = Just $ J.DocumentLinkOptions $ Just $ isJust $ documentLinkResolveHandler h + , J._colorProvider = Just $ J.ColorOptionsStatic $ isJust $ documentColorHandler h + , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ isJust $ foldingRangeHandler h + , J._executeCommandProvider = executeCommandProvider + , J._workspace = Just workspace + -- TODO: Add something for experimental + , J._experimental = Nothing :: Maybe J.Value + } + where + supported (Just _) = Just True + supported Nothing = Nothing + + singleton :: a -> [a] + singleton x = [x] + + completionProvider + | isJust $ completionHandler h = Just $ + J.CompletionOptions + (Just $ isJust $ completionResolveHandler h) + (map singleton <$> completionTriggerCharacters o) + (map singleton <$> completionAllCommitCharacters o) + | otherwise = Nothing + + codeActionProvider + | isJust $ codeActionHandler h = Just (J.CodeActionOptions (codeActionKinds o)) + | otherwise = Just (J.CodeActionOptionsStatic False) + + signatureHelpProvider + | isJust $ signatureHelpHandler h = Just $ + J.SignatureHelpOptions + (map singleton <$> signatureHelpTriggerCharacters o) + (map singleton <$> signatureHelpRetriggerCharacters o) + | otherwise = Nothing + + documentOnTypeFormattingProvider + | isJust $ documentOnTypeFormattingHandler h + , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) + | isJust $ documentOnTypeFormattingHandler h + , Nothing <- documentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing + + executeCommandProvider + | isJust $ executeCommandHandler h + , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions (J.List cmds)) + | isJust $ executeCommandHandler h + , Nothing <- executeCommandCommands o = + error "executeCommandCommands needs to be set if a executeCommandHandler is set" + | otherwise = Nothing + + sync = case textDocumentSync o of + Just x -> Just (J.TDSOptions x) + Nothing -> Nothing - sendResponse tvarCtx $ RspInitialize res + workspace = J.WorkspaceOptions workspaceFolder + workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of + Just _ -> Just $ + -- sign up to receive notifications + J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) + Nothing -> Nothing progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do From 9bc33425066e9a76a4f6be71551dabeb06c370a3 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 27 Oct 2019 20:59:04 +0000 Subject: [PATCH 3/4] Fix typo --- src/Language/Haskell/LSP/Core.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index d7d7ca0cf..695ec0584 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -846,7 +846,7 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori sendResponse tvarCtx $ RspInitialize res --- | Infers the capabilities based on register handlers, and sets the appropriate options. +-- | Infers the capabilities based on registered handlers, and sets the appropriate options. serverCapabilities :: Options -> Handlers -> J.InitializeResponseCapabilitiesInner serverCapabilities o h = J.InitializeResponseCapabilitiesInner From 1e49f5dd17b59daaab4544b7d4277ce82d93a035 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 1 Nov 2019 19:47:53 +0000 Subject: [PATCH 4/4] Default to codeactionoptionsstatic if codeactionkinds is not set Also fix some providers being errenously set --- src/Language/Haskell/LSP/Core.hs | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 695ec0584..60bdde14a 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -33,7 +33,7 @@ import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class -import Control.Lens ( (<&>), (^.) ) +import Control.Lens ( (<&>), (^.), (^?), _Just ) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B @@ -840,15 +840,17 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp Nothing -> do - let capa = serverCapabilities (resOptions ctx) (resHandlers ctx) + let capa = serverCapabilities (getCapabilities params) (resOptions ctx) (resHandlers ctx) -- TODO: wrap this up into a fn to create a response message res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing sendResponse tvarCtx $ RspInitialize res -- | Infers the capabilities based on registered handlers, and sets the appropriate options. -serverCapabilities :: Options -> Handlers -> J.InitializeResponseCapabilitiesInner -serverCapabilities o h = +-- A provider should be set to Nothing if the server does not support it, unless it is a +-- static option. +serverCapabilities :: C.ClientCapabilities -> Options -> Handlers -> J.InitializeResponseCapabilitiesInner +serverCapabilities clientCaps o h = J.InitializeResponseCapabilitiesInner { J._textDocumentSync = sync , J._hoverProvider = supported (hoverHandler h) @@ -862,12 +864,14 @@ serverCapabilities o h = , J._documentSymbolProvider = supported (documentSymbolHandler h) , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) , J._codeActionProvider = codeActionProvider - , J._codeLensProvider = Just $ J.CodeLensOptions $ supported $ codeLensResolveHandler h + , J._codeLensProvider = supported' (codeLensHandler h) $ J.CodeLensOptions $ + supported (codeLensResolveHandler h) , J._documentFormattingProvider = supported (documentFormattingHandler h) , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h - , J._documentLinkProvider = Just $ J.DocumentLinkOptions $ Just $ isJust $ documentLinkResolveHandler h + , J._documentLinkProvider = supported' (documentLinkHandler h) $ J.DocumentLinkOptions $ + Just $ isJust $ documentLinkResolveHandler h , J._colorProvider = Just $ J.ColorOptionsStatic $ isJust $ documentColorHandler h , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ isJust $ foldingRangeHandler h , J._executeCommandProvider = executeCommandProvider @@ -876,8 +880,10 @@ serverCapabilities o h = , J._experimental = Nothing :: Maybe J.Value } where - supported (Just _) = Just True - supported Nothing = Nothing + supported x = supported' x True + + supported' (Just _) = Just + supported' Nothing = const Nothing singleton :: a -> [a] singleton x = [x] @@ -890,8 +896,13 @@ serverCapabilities o h = (map singleton <$> completionAllCommitCharacters o) | otherwise = Nothing + clientSupportsCodeActionKinds = isJust $ + clientCaps ^? J.textDocument . _Just . J.codeAction . _Just . J.codeActionLiteralSupport + codeActionProvider - | isJust $ codeActionHandler h = Just (J.CodeActionOptions (codeActionKinds o)) + | clientSupportsCodeActionKinds + , isJust $ codeActionHandler h = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o) + | isJust $ codeActionHandler h = Just (J.CodeActionOptionsStatic True) | otherwise = Just (J.CodeActionOptionsStatic False) signatureHelpProvider