Fixes pragma plugin offering incorrect code actions #3673

ghcide/src/Development/IDE/Core/Compile.hs

@@ -34,6 +34,8 @@ module Development.IDE.Core.Compile
   , ml_core_file
   , coreFileToLinkable
   , TypecheckHelpers(..)
+  , sourceTypecheck
+  , sourceParser
   ) where
 
 import           Control.Monad.IO.Class
@@ -141,6 +143,12 @@ import GHC.Driver.Config.CoreToStg.Prep
 import GHC.Core.Lint.Interactive
 #endif
 
+--Simple constansts to make sure the source is consistently named
+sourceTypecheck :: T.Text
+sourceTypecheck = "typecheck"
+sourceParser :: T.Text
+sourceParser = "parser"
+
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
     :: IdeOptions
@@ -184,13 +192,13 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
         case initialized of
           Left errs -> return (errs, Nothing)
           Right (modSummary', hsc) -> do
-            (warnings, etcm) <- withWarnings "typecheck" $ \tweak ->
+            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
                 let
                   session = tweak (hscSetFlags dflags hsc)
                    -- TODO: maybe settings ms_hspp_opts is unnecessary?
                   mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
                 in
-                  catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
+                  catchSrcErrors (hsc_dflags hsc) sourceTypecheck $ do
                     tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
             let errorPipeline = unDefer . hideDiag dflags . tagDiag
                 diags = map errorPipeline warnings
@@ -1254,7 +1262,7 @@ parseHeader dflags filename contents = do
    let loc  = mkRealSrcLoc (Util.mkFastString filename) 1 1
    case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of
      PFailedWithErrorMessages msgs ->
-        throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags
+        throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
      POk pst rdr_module -> do
         let (warns, errs) = renderMessages $ getPsMessages pst dflags
 
@@ -1268,9 +1276,9 @@ parseHeader dflags filename contents = do
         -- errors are those from which a parse tree just can't
         -- be produced.
         unless (null errs) $
-            throwE $ diagFromErrMsgs "parser" dflags errs
+            throwE $ diagFromErrMsgs sourceParser dflags errs
 
-        let warnings = diagFromErrMsgs "parser" dflags warns
+        let warnings = diagFromErrMsgs sourceParser dflags warns
         return (warnings, rdr_module)
 
 -- | Given a buffer, flags, and file path, produce a
@@ -1287,7 +1295,7 @@ parseFileContents env customPreprocessor filename ms = do
        dflags = ms_hspp_opts ms
        contents = fromJust $ ms_hspp_buf ms
    case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of
-     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags
+     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
      POk pst rdr_module ->
          let
              hpm_annotations = mkApiAnns pst
@@ -1297,9 +1305,9 @@ parseFileContents env customPreprocessor filename ms = do
                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
 
                unless (null errs) $
-                  throwE $ diagFromStrings "parser" DiagnosticSeverity_Error errs
+                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs
 
-               let preproc_warnings = diagFromStrings "parser" DiagnosticSeverity_Warning preproc_warns
+               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns
                (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages
                let (warns, errs) = renderMessages msgs
 
@@ -1313,7 +1321,7 @@ parseFileContents env customPreprocessor filename ms = do
                -- errors are those from which a parse tree just can't
                -- be produced.
                unless (null errs) $
-                 throwE $ diagFromErrMsgs "parser" dflags errs
+                 throwE $ diagFromErrMsgs sourceParser dflags errs
 
 
                -- To get the list of extra source files, we take the list
@@ -1348,7 +1356,7 @@ parseFileContents env customPreprocessor filename ms = do
                srcs2 <- liftIO $ filterM doesFileExist srcs1
 
                let pm = ParsedModule ms parsed' srcs2 hpm_annotations
-                   warnings = diagFromErrMsgs "parser" dflags warns
+                   warnings = diagFromErrMsgs sourceParser dflags warns
                pure (warnings ++ preproc_warnings, pm)
 
 loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs

@@ -23,6 +23,7 @@ import           Data.Maybe                           (isNothing, listToMaybe,
 import qualified Data.Set                             as Set
 import qualified Data.Text                            as T
 import           Development.IDE
+import           Development.IDE.Core.Compile         (sourceTypecheck)
 import           Development.IDE.Core.PositionMapping (fromCurrentRange)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Util
@@ -91,7 +92,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
     where
         diags = context ^. L.diagnostics
 
-        ghcDiags = filter (\d -> d ^. L.source == Just "typecheck") diags
+        ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags
         methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags
 
         mkActions

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

@@ -16,6 +16,7 @@ import           Control.Monad                 (void)
 import           Data.Maybe
 import           Data.Row                      ((.==))
 import qualified Data.Text                     as T
+import           Development.IDE.Core.Compile  (sourceTypecheck)
 import qualified Ide.Plugin.Class              as Class
 import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
@@ -154,7 +155,7 @@ goldenCodeLens title path idx =
 goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
 goldenWithClass title path desc act =
   goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
-    _ <- waitForDiagnosticsFromSource doc "typecheck"
+    _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
     actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
     act actions
     void $ skipManyTill anyMessage (getDocumentEdit doc)
@@ -164,7 +165,7 @@ expectCodeActionsAvailable title path actionTitles =
   testCase title $ do
     runSessionWithServer classPlugin testDataDir $ do
       doc <- openDoc (path <.> "hs") "haskell"
-      _ <- waitForDiagnosticsFromSource doc "typecheck"
+      _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
       caResults <- getAllCodeActions doc
       liftIO $ map (^? _CACodeAction . L.title) caResults
         @?= expectedActions

plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -58,6 +58,8 @@ import           Data.Typeable
 import           Development.IDE                                    hiding
                                                                     (Error,
                                                                      getExtensions)
+import           Development.IDE.Core.Compile                       (sourceParser,
+                                                                     sourceTypecheck)
 import           Development.IDE.Core.Rules                         (defineNoFile,
                                                                      getParsedModuleWithComments)
 import           Development.IDE.Core.Shake                         (getDiagnostics)
@@ -271,7 +273,7 @@ rules recorder plugin = do
         LSP.Diagnostic {
             _range    = srcSpanToRange l
           , _severity = Just LSP.DiagnosticSeverity_Information
-          , _code     = Just (InR "parser")
+          , _code     = Just (InR sourceParser)
           , _source   = Just "hlint"
           , _message  = T.unlines [T.pack msg,T.pack contents]
           , _relatedInformation = Nothing

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

@@ -24,6 +24,8 @@ import qualified Data.Map                           as M
 import           Data.Maybe                         (catMaybes)
 import qualified Data.Text                          as T
 import           Development.IDE
+import           Development.IDE.Core.Compile       (sourceParser,
+                                                     sourceTypecheck)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
 import qualified Development.IDE.Spans.Pragmas      as Pragmas
@@ -137,7 +139,8 @@ warningBlacklist = ["deferred-type-errors"]
 -- | 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} = genPragma _message
+suggestAddPragma mDynflags Diagnostic {_message, _source}
+    | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
   where
     genPragma target =
       [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
@@ -149,6 +152,7 @@ suggestAddPragma mDynflags Diagnostic {_message} = genPragma _message
         -- 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]

test/functional/FunctionalCodeAction.hs

@@ -4,22 +4,22 @@
 
 module FunctionalCodeAction (tests) where
 
-import           Control.Lens               hiding (List)
+import           Control.Lens                 hiding (List)
 import           Control.Monad
 import           Data.Aeson
-import           Data.Aeson.Lens            (_Object)
+import           Data.Aeson.Lens              (_Object)
 import           Data.List
-import qualified Data.Map                   as M
+import qualified Data.Map                     as M
 import           Data.Maybe
-import qualified Data.Text                  as T
+import qualified Data.Text                    as T
+import           Development.IDE.Core.Compile (sourceTypecheck)
+import           Development.IDE.Test         (configureCheckProject)
 import           Ide.Plugin.Config
-import qualified Language.LSP.Protocol.Lens as L
-import           Language.LSP.Test          as Test
+import qualified Language.LSP.Protocol.Lens   as L
+import           Language.LSP.Test            as Test
 import           Test.Hls
-import           Test.Hspec.Expectations
-
-import           Development.IDE.Test       (configureCheckProject)
 import           Test.Hls.Command
+import           Test.Hspec.Expectations
 
 {-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
 
@@ -43,7 +43,7 @@ renameTests = testGroup "rename suggestions" [
     testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do
         doc <- openDoc "CodeActionRename.hs" "haskell"
 
-        _ <- waitForDiagnosticsFromSource doc "typecheck"
+        _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
 
         cars <- getAllCodeActions doc
         replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"]
@@ -58,7 +58,7 @@ renameTests = testGroup "rename suggestions" [
             configureCheckProject False
             doc <- openDoc "CodeActionRename.hs" "haskell"
 
-            _ <- waitForDiagnosticsFromSource doc "typecheck"
+            _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
 
             cars <- getAllCodeActions doc
             cmd <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"]
@@ -235,7 +235,7 @@ redundantImportTests = testGroup "redundant import code actions" [
         runSession hlsCommand fullCaps "test/testdata/redundantImportTest/" $ do
             doc <- openDoc "src/CodeActionRedundant.hs" "haskell"
 
-            diags <- waitForDiagnosticsFromSource doc "typecheck"
+            diags <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
             liftIO $ expectDiagnostic diags [ "The import of", "Data.List", "is redundant" ]
             liftIO $ expectDiagnostic diags [ "Empty", "from module", "Data.Sequence" ]
 
@@ -281,7 +281,7 @@ redundantImportTests = testGroup "redundant import code actions" [
 
     , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
         doc <- openDoc "src/MultipleImports.hs" "haskell"
-        _   <- waitForDiagnosticsFromSource doc "typecheck"
+        _   <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
         cas <- getAllCodeActions doc
         cmd <- liftIO $ inspectCommand cas ["redundant import"]
         executeCommand cmd
@@ -303,7 +303,7 @@ typedHoleTests = testGroup "typed hole code actions" [
         runSession hlsCommand fullCaps "test/testdata" $ do
             disableWingman
             doc <- openDoc "TypedHoles.hs" "haskell"
-            _ <- waitForDiagnosticsFromSource doc "typecheck"
+            _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
             cas <- getAllCodeActions doc
             liftIO $ do
                 expectCodeAction cas ["replace _ with minBound"]
@@ -324,7 +324,7 @@ typedHoleTests = testGroup "typed hole code actions" [
           testCase "doesn't work when wingman is active" $
           runSession hlsCommand fullCaps "test/testdata" $ do
               doc <- openDoc "TypedHoles.hs" "haskell"
-              _ <- waitForDiagnosticsFromSource doc "typecheck"
+              _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
               cas <- getAllCodeActions doc
               liftIO $ do
                   dontExpectCodeAction cas ["replace _ with minBound"]
@@ -334,7 +334,7 @@ typedHoleTests = testGroup "typed hole code actions" [
             runSession hlsCommand fullCaps "test/testdata" $ do
                 disableWingman
                 doc <- openDoc "TypedHoles2.hs" "haskell"
-                _ <- waitForDiagnosticsFromSource doc "typecheck"
+                _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
                 cas <- getAllCodeActions doc
 
                 liftIO $ do
@@ -359,7 +359,7 @@ typedHoleTests = testGroup "typed hole code actions" [
           testCase "doesnt show more suggestions when wingman is active" $
             runSession hlsCommand fullCaps "test/testdata" $ do
                 doc <- openDoc "TypedHoles2.hs" "haskell"
-                _ <- waitForDiagnosticsFromSource doc "typecheck"
+                _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
                 cas <- getAllCodeActions doc
 
                 liftIO $ do
@@ -373,7 +373,7 @@ signatureTests = testGroup "missing top level signature code actions" [
       runSession hlsCommand fullCaps "test/testdata/" $ do
         doc <- openDoc "TopLevelSignature.hs" "haskell"
 
-        _ <- waitForDiagnosticsFromSource doc "typecheck"
+        _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
         cas <- getAllCodeActions doc
 
         liftIO $ expectCodeAction cas ["add signature: main :: IO ()"]
@@ -400,7 +400,7 @@ unusedTermTests = testGroup "unused term code actions" [
         runSession hlsCommand fullCaps "test/testdata/" $ do
           doc <- openDoc "UnusedTerm.hs" "haskell"
 
-          _ <- waitForDiagnosticsFromSource doc "typecheck"
+          _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
           cars <- getAllCodeActions doc
           prefixImUnused <- liftIO $ inspectCodeAction cars ["Prefix imUnused with _"]