Split pragmas plugin by providers + decrease disable-warning priority

Fixes #3636. Fixes #3636.
haskell · Jun 11, 2023 · 0381290 · 0381290
1 parent 79747f4
commit 0381290
Show file tree

Hide file tree

Showing 3 changed files with 92 additions and 59 deletions.
diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
@@ -9,7 +9,9 @@
 
 -- | Provides code actions to add missing pragmas (whenever GHC suggests to)
 module Ide.Plugin.Pragmas
-  ( descriptor
+  ( suggestPragmaDescriptor
+  , completionDescriptor
+  , suggestDisableWarningDescriptor
   -- For testing
   , validPragmas
   ) where
@@ -33,22 +35,40 @@ import qualified Text.Fuzzy                         as Fuzzy
 
 -- ---------------------------------------------------------------------
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId)
-  { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider
-                  <> mkPluginHandler J.STextDocumentCompletion completion
+suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState
+suggestPragmaDescriptor plId = (defaultPluginDescriptor plId)
+  { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction suggestPragmaProvider
+  , pluginPriority = defaultPluginPriority + 1000
+  }
+
+completionDescriptor :: PluginId -> PluginDescriptor IdeState
+completionDescriptor plId = (defaultPluginDescriptor plId)
+  { pluginHandlers = mkPluginHandler J.STextDocumentCompletion completion
   , pluginPriority = ghcideCompletionsPluginPriority + 1
   }
 
+suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState
+suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId)
+  { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction suggestDisableWarningProvider
+    -- #3636 Suggestions to disable warnings should appear last.
+  , pluginPriority = 0
+  }
+
 -- ---------------------------------------------------------------------
 -- | Title and pragma
 type PragmaEdit = (T.Text, Pragma)
 
 data Pragma = LangExt T.Text | OptGHC T.Text
   deriving (Show, Eq, Ord)
 
-codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
-codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly))
+suggestPragmaProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
+suggestPragmaProvider = mkCodeActionProvider suggest
+
+suggestDisableWarningProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
+suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
+
+mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'J.TextDocumentCodeAction
+mkCodeActionProvider mkSuggest state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly))
   | let J.TextDocumentIdentifier{ _uri = uri } = docId
   , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do
       -- ghc session to get some dynflags even if module isn't parsed
@@ -60,7 +80,7 @@ codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionCont
       case ghcSession of
         Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) ->
           let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
-              pedits = nubOrdOn snd . concat $ suggest parsedModuleDynFlags <$> diags
+              pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags)
           in
             pure $ Right $ List $ pragmaEditToAction uri nextPragmaInfo <$> pedits
         Nothing -> pure $ Right $ List []
@@ -95,7 +115,6 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
 suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
 suggest dflags diag =
   suggestAddPragma dflags diag
-    ++ suggestDisableWarning diag
 
 -- ---------------------------------------------------------------------