Implement PluginMethod for hard-wired in handlers (haskell#2977)

Don't hard-wire handlers, but make sure all handlers are associated to a PluginDescriptor, s.t. we can check that the handler is actually enabled for a given request.

Author: fendor

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -5,18 +5,20 @@
 
 -- | Display information on hover.
 module Development.IDE.LSP.HoverDefinition
- ( setIdeHandlers
+ (
  -- * For haskell-language-server
- , hover
+ hover
  , gotoDefinition
  , gotoTypeDefinition
+ , documentHighlight
+ , references
+ , wsSymbols
  ) where
 
 import Control.Monad.IO.Class
 import Development.IDE.Core.Actions
 import Development.IDE.Core.Rules
 import Development.IDE.Core.Shake
-import Development.IDE.LSP.Server
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import qualified Language.LSP.Server as LSP
@@ -53,18 +55,6 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
 foundHover (mbRange, contents) =
  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
 
-setIdeHandlers :: LSP.Handlers (ServerM c)
-setIdeHandlers = mconcat
- [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} ->
- gotoDefinition ide TextDocumentPositionParams{..}
- , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} ->
- gotoTypeDefinition ide TextDocumentPositionParams{..}
- , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} ->
- documentHighlight ide TextDocumentPositionParams{..}
- , requestHandler STextDocumentReferences references
- , requestHandler SWorkspaceSymbol wsSymbols
- ]
-
 -- | Respond to and log a hover or go-to-definition request
 request
  :: T.Text

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -35,7 +35,6 @@ import UnliftIO.Exception
 import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Shake hiding (Log)
 import Development.IDE.Core.Tracing
-import Development.IDE.LSP.HoverDefinition
 import Development.IDE.Types.Logger
 
 import Control.Monad.IO.Unlift (MonadUnliftIO)
@@ -120,17 +119,12 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur
  cancelled <- readTVar cancelledRequests
  unless (reqId `Set.member` cancelled) retry
 
- let ideHandlers = mconcat
- [ setIdeHandlers
- , userHandlers
- ]
-
  -- Send everything over a channel, since you need to wait until after initialise before
  -- LspFuncs is available
  clientMsgChan :: Chan ReactorMessage <- newChan
 
  let asyncHandlers = mconcat
- [ ideHandlers
+ [ userHandlers
  , cancelHandler cancelRequest
  , exitHandler exit
  , shutdownHandler stopReactorLoop

ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

@@ -49,7 +49,16 @@ descriptors recorder =
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
  { pluginHandlers = mkPluginHandler STextDocumentHover hover'
- <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider,
+ <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider
+ <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} ->
+ gotoDefinition ide TextDocumentPositionParams{..})
+ <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->
+ gotoTypeDefinition ide TextDocumentPositionParams{..})
+ <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->
+ documentHighlight ide TextDocumentPositionParams{..})
+ <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params)
+ <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params),
+
  pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}
  }
 

hls-plugin-api/src/Ide/Types.hs

@@ -205,6 +205,25 @@ instance PluginMethod TextDocumentCodeAction where
  , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed
  | otherwise = False
 
+instance PluginMethod TextDocumentDefinition where
+ pluginEnabled _ _ _ = True
+ combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod TextDocumentTypeDefinition where
+ pluginEnabled _ _ _ = True
+ combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod TextDocumentDocumentHighlight where
+ pluginEnabled _ _ _ = True
+ combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod TextDocumentReferences where
+ pluginEnabled _ _ _ = True
+ combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod WorkspaceSymbol where
+ pluginEnabled _ _ _ = True
+
 instance PluginMethod TextDocumentCodeLens where
  pluginEnabled _ = pluginEnabledConfig plcCodeLensOn
 instance PluginMethod TextDocumentRename where