Teach HLS about different file extensions (#2945)

* Fix parameter switch-up * Generalise file extension handling for plugins NotificationHandler now distinguishes between different file extensions RequestHandler distinguishes between different file extensions * Introduce PluginMethod Typeclass hierarchy The hierarchy looks as follows: PluginMethod (pluginEnabled) | ----------------------------------- | | PluginRequestMethod PluginNotificationMethod * Add example plugin * Improve documentation for plugins * Simplify Plugin Handling code Co-authored-by: Jana Chadt <[email protected]> Co-authored-by: Jana Chadt <[email protected]> Co-authored-by: Fendor <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
haskell · Jun 22, 2022 · 907a6e6 · 907a6e6
1 parent 0ba7c8d
commit 907a6e6
Show file tree

Hide file tree

Showing 7 changed files with 406 additions and 72 deletions.
diff --git a/exe/Plugins.hs b/exe/Plugins.hs
@@ -13,6 +13,7 @@ import           Development.IDE                   (IdeState)
 import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
 import qualified Ide.Plugin.Example                as Example
 import qualified Ide.Plugin.Example2               as Example2
+import qualified Ide.Plugin.ExampleCabal           as ExampleCabal
 
 -- haskell-language-server optional plugins
 #if qualifyImportedNames
@@ -204,4 +205,5 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
     examplePlugins =
       [Example.descriptor  pluginRecorder "eg"
       ,Example2.descriptor pluginRecorder "eg2"
+      ,ExampleCabal.descriptor pluginRecorder "ec"
       ]
diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/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 recorder) id <>
+    mkPlugin (extensibleNotificationPlugins recorder) id <>
     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
     where
 
@@ -153,55 +153,66 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
 
 -- ---------------------------------------------------------------------
 
-extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
-extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
+extensiblePlugins ::  Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
+extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
   where
     IdeHandlers handlers' = foldMap bakePluginId xs
-    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
-    bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map
-      (\(PluginHandler f) -> IdeHandler [(pid,f pid)])
+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers
+    bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map
+      (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,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'
+        -- Only run plugins that are allowed to run on this request
+        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc 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
+          Nothing -> do
+            logWith recorder Info LogNoEnabledPlugins
+            pure $ Left $ ResponseError InvalidRequest
+              (  "No plugin enabled for " <> T.pack (show m) 
+              <> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) 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
+                handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs
+            es <- runConcurrently msg (show m) handlers 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
+
 -- ---------------------------------------------------------------------
 
-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
     IdeNotificationHandlers handlers' = foldMap bakePluginId xs
-    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers
-    bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map
-      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)])
+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers
+    bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map
+      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,pluginDesc,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'
+        -- Only run plugins that are allowed to run on this request
+        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'
         case nonEmpty fs of
           Nothing -> do
-              logWith recorder Info LogNoEnabledPlugins
-              pure ()
+            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
+            mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs
 
 -- ---------------------------------------------------------------------
 
@@ -210,6 +221,7 @@ runConcurrently
   => (SomeException -> PluginId -> T.Text)
   -> String -- ^ label
   -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
+  -- ^ Enabled plugin actions that we are allowed to run
   -> a
   -> b
   -> m (NonEmpty (Either ResponseError d))
@@ -223,11 +235,11 @@ combineErrors xs  = ResponseError InternalError (T.pack (show xs)) Nothing
 
 -- | Combine the 'PluginHandler' for all plugins
 newtype IdeHandler (m :: J.Method FromClient Request)
-  = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]
+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]
 
 -- | Combine the 'PluginHandler' for all plugins
 newtype IdeNotificationHandler (m :: J.Method FromClient Notification)
-  = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]
+  = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]
 -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`
 
 -- | Combine the 'PluginHandlers' for all plugins

diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -6721,7 +6721,7 @@ unitTests recorder logger = do
                 ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)
 
         testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do
-            _ <- createDoc "haskell" "A.hs" "module A where"
+            _ <- createDoc "A.hs" "haskell" "module A where"
             waitForProgressDone
             actualOrder <- liftIO $ readIORef orderRef
 

diff --git a/haskell-language-server.cabal b/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)

diff --git a/hls-plugin-api/hls-plugin-api.cabal b/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