Generalise file extension handling for plugins

NotificationHandler now distinguishes between different file extensions
RequestHandler distinguishes between different file extensions

Author: VeryMilkyJoe

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

@@ -58,8 +58,8 @@ asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin C
 asGhcIdePlugin recorder (IdePlugins ls) =
     mkPlugin rulesPlugins HLS.pluginRules <>
     mkPlugin executeCommandPlugins HLS.pluginCommands <>
-    mkPlugin extensiblePlugins HLS.pluginHandlers <>
-    mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <>
+    mkPlugin extensiblePlugins id <>
+    mkPlugin (extensibleNotificationPlugins recorder) id <>
     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
     where
 
@@ -153,55 +153,80 @@ 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 = 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'
-        case nonEmpty fs of
-          Nothing -> pure $ Left $ ResponseError InvalidRequest
-            ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))
-            Nothing
-          Just fs -> do
-            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
-            es <- runConcurrently msg (show m) fs ide params
-            let (errs,succs) = partitionEithers $ toList es
-            case nonEmpty succs of
-              Nothing -> pure $ Left $ combineErrors errs
-              Just xs -> do
-                caps <- LSP.getClientCapabilities
-                pure $ Right $ combineResponses m config caps params xs
+        let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs'
+        cleanPluginInfo <- collectPluginDescriptors pluginInfo []
+        case cleanPluginInfo of
+          Left err -> pure $ Left err
+          Right pluginInfos -> do
+            let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos 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))
+                Nothing
+              Just fs -> do
+                let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
+                es <- runConcurrently msg (show m) fs ide params
+                let (errs,succs) = partitionEithers $ toList es
+                case nonEmpty succs of
+                  Nothing -> pure $ Left $ combineErrors errs
+                  Just xs -> do
+                    caps <- LSP.getClientCapabilities
+                    pure $ Right $ combineResponses m config caps params xs
+
+collectPluginDescriptors :: [(PluginId, Maybe (PluginDescriptor c))] -> [(PluginId, PluginDescriptor c)] -> LSP.LspM Config (Either ResponseError [(PluginId, PluginDescriptor c)])
+collectPluginDescriptors ((pid, Nothing):_) _ = pure $ Left $ ResponseError InvalidRequest
+        ("No plugindescriptor found for " <>  pidT <> ", available: ")
+        Nothing
+  where
+    PluginId pidT = pid
+collectPluginDescriptors ((pid, Just desc):xs) ys = collectPluginDescriptors xs (ys ++ [(pid, desc)])
+collectPluginDescriptors [] ys = pure $ Right ys
+
 -- ---------------------------------------------------------------------
 
-extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
+extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
 extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers }
   where
+    getPluginDescriptor pid = lookup pid xs
     IdeNotificationHandlers handlers' = foldMap bakePluginId xs
-    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers
-    bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map
+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers
+    bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map
       (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)])
       hs
+      where PluginNotificationHandlers hs = HLS.pluginNotificationHandlers pluginDesc
     handlers = mconcat $ do
       (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'
       pure $ notificationHandler m $ \ide vfs params -> do
         config <- Ide.PluginUtils.getClientConfig
-        let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs'
-        case nonEmpty fs of
-          Nothing -> do
-              logWith recorder Info LogNoEnabledPlugins
-              pure ()
-          Just fs -> do
-            -- We run the notifications in order, so the core ghcide provider
-            -- (which restarts the shake process) hopefully comes last
-              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs
+        let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs'
+        cleanPluginInfo <- collectPluginDescriptors pluginInfo []
+        case cleanPluginInfo of
+          Left _ -> pure ()
+          Right pluginInfos -> do
+            let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled2 m params desc config) (zip pluginInfos fs')
+            case nonEmpty fs of
+                Nothing -> do
+                  logWith recorder Info LogNoEnabledPlugins
+                  pure ()
+                Just fs -> do
+                  -- We run the notifications in order, so the core ghcide provider
+                  -- (which restarts the shake process) hopefully comes last
+                  mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs
 
 -- ---------------------------------------------------------------------
 

haskell-language-server.cabal

@@ -226,7 +226,8 @@ flag dynamic
 common example-plugins
   hs-source-dirs: plugins/default/src
   other-modules: Ide.Plugin.Example,
-                 Ide.Plugin.Example2
+                 Ide.Plugin.Example2,
+                 Ide.Plugin.ExampleCabal
 
 common class
   if flag(class)

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

@@ -43,6 +43,7 @@ library
     , Diff                  ^>=0.4.0
     , dlist
     , extra
+    , filepath
     , ghc
     , hashable
     , hls-graph             ^>= 1.7

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

@@ -69,6 +69,7 @@ import           Language.LSP.Types.Lens         as J (HasChildren (children),
 import           Language.LSP.VFS
 import           OpenTelemetry.Eventlog
 import           Options.Applicative             (ParserInfo)
+import           System.FilePath
 import           System.IO.Unsafe
 import           Text.Regex.TDFA.Text            ()
 
@@ -117,6 +118,7 @@ data PluginDescriptor ideState =
                    , pluginNotificationHandlers :: PluginNotificationHandlers ideState
                    , pluginModifyDynflags :: DynFlagsModifications
                    , pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
+                   , pluginFileType       :: [T.Text]
                    }
 
 -- | An existential wrapper of 'Properties'
@@ -162,7 +164,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
@@ -177,11 +179,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)
@@ -205,12 +210,31 @@ instance PluginMethod TextDocumentCodeAction where
         , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) 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
@@ -219,7 +243,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
@@ -241,7 +268,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
@@ -270,32 +300,82 @@ instance PluginMethod TextDocumentCompletion where
           consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))
 
 instance PluginMethod TextDocumentFormatting where
-  pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
-  combineResponses _ _ _ _ (x :| _) = x
+  pluginEnabled STextDocumentFormatting msgParams pluginDesc conf =
+    pluginResponsible uri pluginDesc && PluginId (formattingProvider 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 TextDocumentSelectionRange where
-  pluginEnabled _ = pluginEnabledConfig plcSelectionRangeOn
+  pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcSelectionRangeOn pid conf
+    where
+      pid = pluginId pluginDesc
   combineResponses _ _ _ _ (x :| _) = x
 
 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
 
 instance PluginMethod CustomMethod where
-  pluginEnabled _ _ _ = True
+  pluginEnabled _ _ _ _ = True
   combineResponses _ _ _ _ (x :| _) = x
 
 -- ---------------------------------------------------------------------
 
+class HasTracing (MessageParams m) => PluginNotificationMethod (m :: Method FromClient Notification)  where
+  pluginEnabled2 :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool
+
+  default pluginEnabled2 :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri)
+                              => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool
+  pluginEnabled2 _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf (pluginId desc))
+    where
+        uri = params ^. J.textDocument . J.uri
+
+instance PluginNotificationMethod TextDocumentDidOpen where
+
+instance PluginNotificationMethod TextDocumentDidChange where
+
+instance PluginNotificationMethod TextDocumentDidSave where
+
+instance PluginNotificationMethod TextDocumentDidClose where
+
+instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where
+  pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc)
+
+instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where
+  pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc)
+
+instance PluginNotificationMethod WorkspaceDidChangeConfiguration where
+  pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc)
+
+instance PluginNotificationMethod Initialized where
+  pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc)
+
+-- ---------------------------------------------------------------------
+
 -- | Methods which have a PluginMethod instance
 data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m)
 instance GEq IdeMethod where
@@ -304,7 +384,7 @@ instance GCompare IdeMethod where
   gcompare (IdeMethod a) (IdeMethod b) = gcompare a b
 
 -- | Methods which have a PluginMethod instance
-data IdeNotification (m :: Method FromClient Notification) = HasTracing (MessageParams m) => IdeNotification (SMethod m)
+data IdeNotification (m :: Method FromClient Notification) = PluginNotificationMethod m => IdeNotification (SMethod m)
 instance GEq IdeNotification where
   geq (IdeNotification a) (IdeNotification b) = geq a b
 instance GCompare IdeNotification where
@@ -353,7 +433,7 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl
 
 -- | Make a handler for plugins with no extra data
 mkPluginNotificationHandler
-  :: HasTracing (MessageParams m)
+  :: PluginNotificationMethod m
   => SClientMethod (m :: Method FromClient Notification)
   -> PluginNotificationMethodHandler ideState m
   -> PluginNotificationHandlers ideState
@@ -373,6 +453,20 @@ defaultPluginDescriptor plId =
     mempty
     mempty
     Nothing
+    [".hs", ".lhs"]
+
+defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState
+defaultCabalPluginDescriptor plId =
+  PluginDescriptor
+    plId
+    mempty
+    mempty
+    mempty
+    defaultConfigDescriptor
+    mempty
+    mempty
+    Nothing
+    [".cabal"]
 
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)

plugins/default/src/Ide/Plugin/ExampleCabal.hs

@@ -0,0 +1,2 @@
+module Ide.Plugin.ExampleCabal where
+