diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index bb036f0b33..3b8ee793a1 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 3ec194f762..3f125ab746 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/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 diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 7b21c3da21..b102c64f73 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 1c4c4ee445..d817de310d 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -58,6 +58,7 @@ import Data.Typeable import Development.IDE hiding (Error, getExtensions) +import Development.IDE.Core.Compile (sourceParser) import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics) @@ -271,7 +272,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 diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index bd37f36a8c..c5110b14b8 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/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] diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 7afde93f97..3121530090 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/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 _"]