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          #-}
@@ -25,14 +26,17 @@ import qualified Data.Map                                 as M
 import           Data.Maybe                               (mapMaybe)
 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
@@ -74,19 +78,25 @@ suggestPragmaProvider = mkCodeActionProvider suggest
 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 _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
-    normalizedFilePath <- getNormalizedFilePathE uri
+  (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
-        pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags
-    pure  $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
+    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
 
 
 
@@ -115,15 +125,15 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
         Nothing
         Nothing
 
-suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
+suggest :: Maybe DynFlags -> FileDiagnostic -> [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
@@ -143,13 +153,10 @@ warningBlacklist =
 -- ---------------------------------------------------------------------
 
 -- | 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}
-    | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
+-- Pragmas are defined by a cuNewrated list of known pragmas, see 'possiblePragmas'.
+suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
+suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
   where
-    genPragma target =
-      [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
     disabled
       | Just dynFlags <- mDynflags =
         -- GHC does not export 'OnOff', so we have to view it as string
@@ -158,25 +165,22 @@ 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 _ _ = []
 
--- | Find all Pragmas are an infix of the search term.
-findPragma :: T.Text -> [T.Text]
-findPragma str = concatMap check possiblePragmas
-  where
-    check p = [p | T.isInfixOf p str]
-
-    -- We exclude the Strict extension as it causes many false positives, see
-    -- the discussion at https://github.com/haskell/ghcide/pull/638
-    --
-    -- We don't include the No- variants, as GHC never suggests disabling an
-    -- extension in an error message.
-    possiblePragmas :: [T.Text]
-    possiblePragmas =
-       [ name
-       | FlagSpec{flagSpecName = T.pack -> name} <- xFlags
-       , "Strict" /= name
-       ]
+suggestsExtension :: FileDiagnostic -> [Extension]
+suggestsExtension message = case   message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of
+    Just s -> concat $ mapMaybe (\case
+      SuggestExtension s -> Just $ ghcHintSuggestsExtension s
+      _ -> Nothing) (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]