Use structured diagnostics in pragmas plugin

Changes suggestion provider in pragmas plugin to
use structured diagnostics and ghc machinery to
generate hints

Author: dyniec

haskell-language-server.cabal

@@ -905,6 +905,7 @@ library hls-pragmas-plugin
     , text
     , transformers
     , containers
+    , ghc
 
 test-suite hls-pragmas-plugin-tests
   import:           defaults, pedantic, test-defaults, warnings

plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiWayIf            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ViewPatterns          #-}
@@ -27,12 +28,17 @@ import qualified Data.Text                                as T
 import           Development.IDE                          hiding (line)
 import           Development.IDE.Core.Compile             (sourceParser,
                                                            sourceTypecheck)
+import           Development.IDE.Core.FileStore           (getVersionedTextDoc)
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat.Error         (msgEnvelopeErrorL)
 import           Development.IDE.Plugin.Completions       (ghcideCompletionsPluginPriority)
 import           Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
 import           Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
 import qualified Development.IDE.Spans.Pragmas            as Pragmas
+import           GHC.Types.Error                          (GhcHint (SuggestExtension),
+                                                           LanguageExtensionHint (..),
+                                                           diagnosticHints)
 import           Ide.Plugin.Error
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens               as L
@@ -69,13 +75,33 @@ data Pragma = LangExt T.Text | OptGHC T.Text
   deriving (Show, Eq, Ord)
 
 suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
-suggestPragmaProvider = mkCodeActionProvider suggest
+suggestPragmaProvider = if ghcVersion /= GHC96 then
+    mkCodeActionProvider suggestAddPragma
+    else mkCodeActionProvider96 suggestAddPragma96
 
 suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
 suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
 
-mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
+mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
 mkCodeActionProvider mkSuggest state _plId
+  (LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do
+    verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
+    normalizedFilePath <- getNormalizedFilePathE (verTxtDocId ^. L.uri)
+    -- ghc session to get some dynflags even if module isn't parsed
+    (hscEnv -> hsc_dflags -> sessionDynFlags, _) <-
+      runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath
+    fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath
+    parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath
+    let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule
+        nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
+    activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case
+        Nothing -> pure $ LSP.InL []
+        Just fileDiags -> do
+            let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags
+            pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions
+
+mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
+mkCodeActionProvider96 mkSuggest state _plId
   (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
     normalizedFilePath <- getNormalizedFilePathE uri
     -- ghc session to get some dynflags even if module isn't parsed
@@ -89,7 +115,6 @@ mkCodeActionProvider mkSuggest state _plId
     pure  $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
 
 
-
 -- | Add a Pragma to the given URI at the top of the file.
 -- It is assumed that the pragma name is a valid pragma,
 -- thus, not validated.
@@ -108,22 +133,17 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
          , let LSP.TextEdit{ _range, _newText } = insertTextEdit ->
              [LSP.TextEdit _range (render p <> _newText), deleteTextEdit]
          | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)]
-
     edit =
       LSP.WorkspaceEdit
         (Just $ M.singleton uri textEdits)
         Nothing
         Nothing
 
-suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
-suggest dflags diag =
-  suggestAddPragma dflags diag
-
 -- ---------------------------------------------------------------------
 
-suggestDisableWarning :: Diagnostic -> [PragmaEdit]
+suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
 suggestDisableWarning diagnostic
-  | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
+  | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL . attachedReason
     =
     [ ("Disable \"" <> w <> "\" warnings", OptGHC w)
     | JSON.String attachedReason <- Foldable.toList attachedReasons
@@ -142,10 +162,24 @@ warningBlacklist =
 
 -- ---------------------------------------------------------------------
 
+-- | Offer to add a missing Language Pragma to the top of a file.
+suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
+suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
+  where
+    disabled
+      | Just dynFlags <- mDynflags =
+        -- GHC does not export 'OnOff', so we have to view it as string
+        mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags)
+      | otherwise =
+        -- When the module failed to parse, we don't have access to its
+        -- dynFlags. In that case, simply don't disable any pragmas.
+        []
+
 -- | Offer to add a missing Language Pragma to the top of a file.
 -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
-suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
-suggestAddPragma mDynflags Diagnostic {_message, _source}
+-- Kept for compatibility with ghc9.6 - it is missing some structured diagnostics
+suggestAddPragma96 :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
+suggestAddPragma96 mDynflags Diagnostic {_message, _source}
     | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
   where
     genPragma target =
@@ -158,7 +192,7 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
         -- When the module failed to parse, we don't have access to its
         -- dynFlags. In that case, simply don't disable any pragmas.
         []
-suggestAddPragma _ _ = []
+suggestAddPragma96 _ _ = []
 
 -- | Find all Pragmas are an infix of the search term.
 findPragma :: T.Text -> [T.Text]
@@ -178,6 +212,20 @@ findPragma str = concatMap check possiblePragmas
        , "Strict" /= name
        ]
 
+suggestsExtension :: FileDiagnostic -> [Extension]
+suggestsExtension message = case   message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of
+    Just s -> concat $ map (\case
+      SuggestExtension s -> ghcHintSuggestsExtension s
+      _ -> []) (diagnosticHints s)
+    _          -> []
+
+ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]
+ghcHintSuggestsExtension (SuggestSingleExtension _ ext)    = [ext]
+ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_))   = [ext] -- ghc suggests any of those, we pick first
+ghcHintSuggestsExtension (SuggestAnyExtension _ [])        = []
+ghcHintSuggestsExtension (SuggestExtensions _ ext)         = ext
+ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext]
+
 -- | All language pragmas, including the No- variants
 allPragmas :: [T.Text]
 allPragmas =