Split pragmas plugin by providers + decrease disable-warning priority

Fixes #3636.

Author: Marc Jakobi

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
 
 -- ---------------------------------------------------------------------
 

plugins/hls-pragmas-plugin/test/Main.hs

@@ -15,8 +15,13 @@ import           Test.Hls.Util           (onlyWorkForGhcVersions)
 main :: IO ()
 main = defaultTestRunner tests
 
+-- FIXME: Combine these plugins into a single one
+
 pragmasPlugin :: PluginTestDescriptor ()
-pragmasPlugin = mkPluginTestDescriptor' descriptor "pragmas"
+pragmasPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas"
+
+pragmasCompletionPlugin :: PluginTestDescriptor ()
+pragmasCompletionPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas"
 
 tests :: TestTree
 tests =
@@ -136,7 +141,7 @@ completionSnippetTests =
 
 completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
 completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
-  testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do
+  testCase testComment $ runSessionWithServer pragmasCompletionPlugin testDataDir $ do
     doc <- openDoc fileName "haskell"
     _ <- waitForDiagnostics
     let te = TextEdit (Range (Position a b) (Position c d)) te'

src/HlsPlugins.hs

@@ -152,7 +152,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
       let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId :
 #endif
 #if hls_pragmas
-      Pragmas.descriptor  "pragmas" :
+      Pragmas.suggestPragmaDescriptor  "pragmas" :
+      Pragmas.completionDescriptor  "pragmas" :
+      Pragmas.suggestDisableWarningDescriptor  "pragmas" :
 #endif
 #if hls_floskell
       Floskell.descriptor "floskell" :