Generalise file extension handling for plugins

Author: Jana Chadt

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

@@ -39,6 +39,7 @@ import           Text.Regex.TDFA.Text         ()
 import           UnliftIO                     (MonadUnliftIO)
 import           UnliftIO.Async               (forConcurrently)
 import           UnliftIO.Exception           (catchAny)
+import Data.Maybe
 
 -- ---------------------------------------------------------------------
 --
@@ -48,7 +49,7 @@ asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
 asGhcIdePlugin (IdePlugins ls) =
     mkPlugin rulesPlugins HLS.pluginRules <>
     mkPlugin executeCommandPlugins HLS.pluginCommands <>
-    mkPlugin extensiblePlugins HLS.pluginHandlers <>
+    mkPlugin extensiblePlugins id <>
     mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <>
     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
     where
@@ -143,19 +144,22 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
 
 -- ---------------------------------------------------------------------
 
-extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
+extensiblePlugins :: [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
 extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
   where
+    getPluginDescriptor pid = fromJust $ lookup pid xs
     IdeHandlers handlers' = foldMap bakePluginId xs
-    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
-    bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map
+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers
+    bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map
       (\(PluginHandler f) -> IdeHandler [(pid,f pid)])
       hs
+      where
+        PluginHandlers hs = HLS.pluginHandlers pluginDesc
     handlers = mconcat $ do
       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'
       pure $ requestHandler m $ \ide params -> do
         config <- Ide.PluginUtils.getClientConfig
-        let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs'
+        let fs = filter (\(pid,_) -> pluginEnabled m params (getPluginDescriptor pid) config) fs'
         case nonEmpty fs of
           Nothing -> pure $ Left $ ResponseError InvalidRequest
             ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))

hls-plugin-api/hls-plugin-api.cabal

@@ -43,6 +43,7 @@ library
     , dependent-sum
     , Diff                  ^>=0.4.0
     , dlist
+    , filepath
     , ghc
     , ghc-api-compat
     , hashable

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

@@ -66,6 +66,7 @@ import           OpenTelemetry.Eventlog
 import           Options.Applicative             (ParserInfo)
 import           System.IO.Unsafe
 import           Text.Regex.TDFA.Text            ()
+import System.FilePath
 
 -- ---------------------------------------------------------------------
 
@@ -158,7 +159,7 @@ defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyPrope
 class HasTracing (MessageParams m) => PluginMethod m where
 
   -- | Parse the configuration to check if this plugin is enabled
-  pluginEnabled :: SMethod m -> PluginId -> Config -> Bool
+  pluginEnabled :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool
 
   -- | How to combine responses from different plugins
   combineResponses
@@ -173,11 +174,14 @@ class HasTracing (MessageParams m) => PluginMethod m where
   combineResponses _method _config _caps _params = sconcat
 
 instance PluginMethod TextDocumentCodeAction where
-  pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn
+  pluginEnabled _ msgParams pluginDesc
+    | pluginResponsible uri pluginDesc = pluginEnabledConfig plcCodeActionsOn (pluginId pluginDesc)
+    | otherwise = const False
+    where
+      uri = msgParams ^. J.textDocument . J.uri
   combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps =
       fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps
     where
-
       compat :: (Command |? CodeAction) -> (Command |? CodeAction)
       compat x@(InL _) = x
       compat x@(InR action)
@@ -196,12 +200,31 @@ instance PluginMethod TextDocumentCodeAction where
         , Just caKind <- ca ^. kind = caKind `elem` allowed
         | otherwise = False
 
+pluginResponsible :: Uri -> PluginDescriptor c -> Bool
+pluginResponsible uri pluginDesc
+    | Just fp <- mfp
+    , T.pack (takeExtension fp) `elem` pluginFileType pluginDesc = True
+    | otherwise = False
+    where
+      mfp = uriToFilePath uri
+
 instance PluginMethod TextDocumentCodeLens where
-  pluginEnabled _ = pluginEnabledConfig plcCodeLensOn
+  pluginEnabled _ msgParams pluginDesc config =
+    pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcCodeLensOn (pluginId pluginDesc) config
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+
 instance PluginMethod TextDocumentRename where
-  pluginEnabled _ = pluginEnabledConfig plcRenameOn
+  pluginEnabled _ msgParams pluginDesc config =  pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcRenameOn (pluginId pluginDesc) config
+   where
+      uri = msgParams ^. J.textDocument . J.uri
 instance PluginMethod TextDocumentHover where
-  pluginEnabled _ = pluginEnabledConfig plcHoverOn
+  pluginEnabled _ msgParams pluginDesc config =  pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcHoverOn (pluginId pluginDesc) config
+   where
+      uri = msgParams ^. J.textDocument . J.uri
   combineResponses _ _ _ _ (catMaybes . toList -> hs) = h
     where
       r = listToMaybe $ mapMaybe (^. range) hs
@@ -210,7 +233,10 @@ instance PluginMethod TextDocumentHover where
             hh                        -> Just $ Hover hh r
 
 instance PluginMethod TextDocumentDocumentSymbol where
-  pluginEnabled _ = pluginEnabledConfig plcSymbolsOn
+  pluginEnabled _ msgParams pluginDesc config =  pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcSymbolsOn (pluginId pluginDesc) config
+    where
+      uri = msgParams ^. J.textDocument . J.uri
   combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res
     where
       uri' = params ^. textDocument . uri
@@ -232,7 +258,10 @@ instance PluginMethod TextDocumentDocumentSymbol where
         in [si] <> children'
 
 instance PluginMethod TextDocumentCompletion where
-  pluginEnabled _ = pluginEnabledConfig plcCompletionOn
+  pluginEnabled _ msgParams pluginDesc config =  pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config
+    where
+      uri = msgParams ^. J.textDocument . J.uri
   combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs
       where
         limit = maxCompletions conf
@@ -261,22 +290,39 @@ instance PluginMethod TextDocumentCompletion where
           consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))
 
 instance PluginMethod TextDocumentFormatting where
-  pluginEnabled STextDocumentFormatting pid conf = 
-    PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid
+  pluginEnabled STextDocumentFormatting msgParams pluginDesc conf =
+    pluginResponsible uri pluginDesc
+      && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+      pid = pluginId pluginDesc
   combineResponses _ _ _ _ x = sconcat x
 
+
 instance PluginMethod TextDocumentRangeFormatting where
-  pluginEnabled _ pid conf = PluginId (formattingProvider conf) == pid
+  pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc
+      && PluginId (formattingProvider conf) == pid
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+      pid = pluginId pluginDesc
   combineResponses _ _ _ _ (x :| _) = x
 
 instance PluginMethod TextDocumentPrepareCallHierarchy where
-  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+  pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc
+      && pluginEnabledConfig plcCallHierarchyOn pid conf
+    where
+      uri = msgParams ^. J.textDocument . J.uri
+      pid = pluginId pluginDesc
 
 instance PluginMethod CallHierarchyIncomingCalls where
-  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+  pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf
+    where
+      pid = pluginId pluginDesc
 
 instance PluginMethod CallHierarchyOutgoingCalls where
-  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+  pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf
+    where
+      pid = pluginId pluginDesc
 
 -- ---------------------------------------------------------------------