Rework Core.Options and infer all server capabilities from handlers

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)
 
@@ -451,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)
 
@@ -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

src/Language/Haskell/LSP/Core.hs

@@ -33,13 +33,14 @@ 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
 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
@@ -95,29 +96,37 @@ 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
-    , 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
-    , colorProvider                    :: Maybe J.ColorOptions
-    , foldingRangeProvider             :: Maybe J.FoldingRangeOptions
-    , executeCommandProvider           :: Maybe J.ExecuteCommandOptions
+    -- |  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]
+    -- | The list of characters that triggers on type formatting.
+    -- If you set `documentOnTypeFormattingHandler`, you **must** set this.
+    , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)
+    -- | 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
@@ -236,7 +245,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 +368,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
@@ -831,67 +840,105 @@ initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ ori
         sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp
 
       Nothing -> do
+        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
 
-        let
-          h = resHandlers ctx
-          o = resOptions  ctx
-
-          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
-
-          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 o
-              , J._signatureHelpProvider            = signatureHelpProvider o
-              , J._definitionProvider               = supported (definitionHandler h)
-              , J._typeDefinitionProvider           = static (typeDefinitionProvider o) (typeDefinitionHandler h)
-              , J._implementationProvider           = implementationProvider o
-              , 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._documentFormattingProvider       = supported (documentFormattingHandler h)
-              , J._documentRangeFormattingProvider  = supported (documentRangeFormattingHandler h)
-              , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o
-              , J._renameProvider                   = renameProvider o
-              , J._documentLinkProvider             = documentLinkProvider o
-              , 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 registered handlers, and sets the appropriate options.
+-- 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)
+    , 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                 = 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             = 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
+    , J._workspace                        = Just workspace
+    -- TODO: Add something for experimental
+    , J._experimental                     = Nothing :: Maybe J.Value
+    }
+  where
+    supported x = supported' x True
+
+    supported' (Just _) = Just
+    supported' Nothing = const 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
+
+    clientSupportsCodeActionKinds = isJust $
+      clientCaps ^? J.textDocument . _Just . J.codeAction . _Just . J.codeActionLiteralSupport
+
+    codeActionProvider
+      | 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
+      | 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