Implement PluginMethod for hard-wired in handlers

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

@@ -224,6 +224,35 @@ pluginResponsible uri pluginDesc
     where
       mfp = uriToFilePath uri
 
+instance PluginMethod TextDocumentDefinition where
+  pluginEnabled _ msgParams pluginDesc _ =
+    pluginResponsible uri pluginDesc
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+  combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod TextDocumentTypeDefinition where
+  pluginEnabled _ msgParams pluginDesc _ =
+    pluginResponsible uri pluginDesc
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+  combineResponses _ _ _ _ (x :| _) = x
+
+instance PluginMethod TextDocumentDocumentHighlight where
+  pluginEnabled _ msgParams pluginDesc _ =
+    pluginResponsible uri pluginDesc
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+
+instance PluginMethod TextDocumentReferences where
+  pluginEnabled _ msgParams pluginDesc _ =
+    pluginResponsible uri pluginDesc
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+
+instance PluginMethod WorkspaceSymbol where
+  pluginEnabled _ _ _ _ = True
+
 instance PluginMethod TextDocumentCodeLens where
   pluginEnabled _ msgParams pluginDesc config =
     pluginResponsible uri pluginDesc