diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-04-19 14:29:18 +0200 |
|---|---|---|
| committer | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-05-25 11:56:42 +0200 |
| commit | e384a1df626a1191437fc9f1b9f5a50d8faa6f7d (patch) | |
| tree | a5f21e76f60e57f1c53eb6b06719ef708b682620 | |
| parent | 11bdf3cdd6efb406839a0ebe33455908a66df805 (diff) | |
| download | haskell-wip/adinapoli-align-ps-messages.tar.gz | |
Support new parser types in GHCwip/adinapoli-align-ps-messages
This commit converts the lexers and all the parser machinery to use the
new parser types and diagnostics infrastructure. Furthermore, it cleans
up the way the parser code was emitting hints.
As a result of this systematic approach, the test output of the
`InfixAppPatErr` and `T984` tests have been changed. Previously they
would emit a `SuggestMissingDo` hint, but this was not at all helpful in
resolving the error, and it was even confusing by just looking at the
original program that triggered the errors.
Update haddock submodule
47 files changed, 1569 insertions, 1307 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 0d515a61f6..f71caa6f15 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -330,7 +330,6 @@ import GHCi.RemoteTypes import qualified GHC.Parser as Parser import GHC.Parser.Lexer import GHC.Parser.Annotation -import GHC.Parser.Errors.Ppr import GHC.Parser.Utils import GHC.Iface.Load ( loadSysInterface ) @@ -1609,7 +1608,7 @@ getTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts - PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with @@ -1620,7 +1619,7 @@ getRichTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the @@ -1800,12 +1799,11 @@ parser str dflags filename = PFailed pst -> let (warns,errs) = getMessages pst in - (foldPsMessages (mkParserWarn dflags) warns - , Left (foldPsMessages mkParserErr errs)) + (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs) POk pst rdr_module -> let (warns,_) = getMessages pst in - (foldPsMessages (mkParserWarn dflags) warns, Right rdr_module) + (GhcPsMessage <$> warns, Right rdr_module) -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index 85b06ea624..bf379ec7da 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -26,7 +26,9 @@ import GHC.Types.Unique.FM import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Parser.CharClass -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () +import GHC.Utils.Error import GHC.Utils.Misc --import TRACE @@ -326,7 +328,9 @@ lexToken = do AlexEOF -> do let span = mkPsSpan loc1 loc1 liftP (setLastToken span 0) return (L span CmmT_EOF) - AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer []) + AlexError (loc2,_) -> + let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer + in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg AlexSkip inp2 _ -> do setInput inp2 lexToken diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index a83feff8cf..d182a6f714 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -239,7 +239,8 @@ import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr import GHC.Types.CostCentre import GHC.Types.ForeignCall @@ -918,7 +919,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name = case lookupUFM machOps name of - Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) [] + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) Just m -> return m exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) @@ -1083,12 +1084,14 @@ parseSafety :: String -> PD Safety parseSafety "safe" = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible -parseSafety str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) [] +parseSafety str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedSafety str) parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr" = return AddrHint parseCmmHint "signed" = return SignedHint -parseCmmHint str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) [] +parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedHint str) -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint @@ -1115,7 +1118,7 @@ happyError = PD $ \_ _ s -> unP srcParseFail s stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do case lookupUFM stmtMacros fun of - Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) [] + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun) Just fcode -> return $ do args <- sequence args_code code (fcode args) @@ -1218,7 +1221,8 @@ foreignCall conv_string results_code expr_code args_code safety ret = do conv <- case conv_string of "C" -> return CCallConv "stdcall" -> return StdCallConv - _ -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) [] + _ -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnknownCConv conv_string) return $ do platform <- getPlatform results <- sequence results_code @@ -1296,7 +1300,7 @@ primCall results_code name args_code = do platform <- PD.getPlatform case lookupUFM (callishMachOps platform) name of - Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) [] + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) Just f -> return $ do results <- sequence results_code args <- sequence args_code @@ -1451,7 +1455,11 @@ initEnv profile = listToUFM [ where platform = profilePlatform profile -parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt])) +parseCmmFile :: DynFlags + -> Module + -> HomeUnit + -> FilePath + -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt])) parseCmmFile dflags this_mod home_unit filename = do buf <- hGetStringBuffer filename let @@ -1474,7 +1482,7 @@ parseCmmFile dflags this_mod home_unit filename = do return (cmm ++ cmm2, used_info) (cmm, _) = runC dflags no_module st fcode (warnings,errors) = getMessages pst - if not (isEmptyBag errors) + if not (isEmptyMessages errors) then return (warnings, errors, Nothing) else return (warnings, errors, Just cmm) where diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs index 77124ad1b2..4a72780c2f 100644 --- a/compiler/GHC/Cmm/Parser/Monad.hs +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -27,7 +27,8 @@ import Control.Monad import GHC.Driver.Session import GHC.Parser.Lexer -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Types.Error ( MsgEnvelope ) import GHC.Types.SrcLoc import GHC.Unit.Types import GHC.Unit.Home @@ -47,7 +48,7 @@ instance Monad PD where liftP :: P a -> PD a liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> PsError) -> PD a +failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a failMsgPD = liftP . failMsgP returnPD :: a -> PD a diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 3d8048e825..dceed41099 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -35,7 +35,6 @@ import GHC.Parser import GHC.Parser.Header import GHC.Parser.Lexer import GHC.Parser.Annotation -import GHC.Parser.Errors.Ppr import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad @@ -106,7 +105,7 @@ doBackpack [src_filename] = do buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) + PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs index cd3b165a65..7a96271403 100644 --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -15,6 +15,7 @@ import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt import GHC.Parser.Lexer import GHC.Runtime.Interpreter (BCOOpts(..)) +import GHC.Utils.Error (mkPlainMsgEnvelope) import GHCi.Message (EvalOpts(..)) import GHC.Conc (getNumProcessors) @@ -39,6 +40,7 @@ initParserOpts = mkParserOpts <$> warningFlags <*> extensionFlags + <*> mkPlainMsgEnvelope <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index f980502f5d..777761f201 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -9,7 +9,7 @@ import GHC.Driver.Session import GHC.Driver.Errors.Types import GHC.Data.Bag import GHC.Prelude -import GHC.Parser.Errors ( PsError(..) ) +import GHC.Parser.Errors.Types import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error @@ -64,7 +64,5 @@ printOrThrowDiagnostics logger dflags msgs -- for dealing with parse errors when the driver is doing dependency analysis. -- Defined here to avoid module loops between GHC.Driver.Error.Types and -- GHC.Driver.Error.Ppr -mkDriverPsHeaderMessage :: PsError -> MsgEnvelope DriverMessage -mkDriverPsHeaderMessage ps_err - = mkPlainErrorMsgEnvelope (errLoc ps_err) $ - DriverPsHeaderMessage (errDesc ps_err) (errHints ps_err) +mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage +mkDriverPsHeaderMessage = fmap DriverPsHeaderMessage diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index 853d83b76b..b8553c0533 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -10,7 +10,7 @@ import GHC.Driver.Errors.Types import GHC.Driver.Flags import GHC.Driver.Session import GHC.HsToCore.Errors.Ppr () -import GHC.Parser.Errors.Ppr (pprPsError) +import GHC.Parser.Errors.Ppr () import GHC.Tc.Errors.Ppr () import GHC.Types.Error import GHC.Unit.Types @@ -69,8 +69,8 @@ instance Diagnostic DriverMessage where diagnosticMessage = \case DriverUnknownMessage m -> diagnosticMessage m - DriverPsHeaderMessage desc hints - -> mkSimpleDecorated $ pprPsError desc hints + DriverPsHeaderMessage m + -> diagnosticMessage m DriverMissingHomeModules missing buildingCabalPackage -> let msg | buildingCabalPackage == YesBuildingCabalPackage = hang @@ -151,8 +151,8 @@ instance Diagnostic DriverMessage where diagnosticHints = \case DriverUnknownMessage m -> diagnosticHints m - DriverPsHeaderMessage _desc hints - -> hints + DriverPsHeaderMessage psMsg + -> diagnosticHints psMsg DriverMissingHomeModules{} -> noHints DriverUnusedPackages{} diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 2519d5597c..142b3b2be9 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -12,7 +12,6 @@ module GHC.Driver.Errors.Types ( -- * Utility functions , hoistTcRnMessage , hoistDsMessage - , foldPsMessages , checkBuildingCabalPackage ) where @@ -25,7 +24,6 @@ import GHC.Driver.Session import GHC.Types.Error import GHC.Unit.Module -import GHC.Parser.Errors ( PsErrorDesc ) import GHC.Parser.Errors.Types ( PsMessage ) import GHC.Tc.Errors.Types ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) @@ -92,14 +90,6 @@ data GhcMessage where ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage ghcUnknownMessage = GhcUnknownMessage --- | Given a collection of @e@ wrapped in a 'Foldable' structure, converts it --- into 'Messages' via the supplied transformation function. -foldPsMessages :: Foldable f - => (e -> MsgEnvelope PsMessage) - -> f e - -> Messages GhcMessage -foldPsMessages f = foldMap (singleMessage . fmap GhcPsMessage . f) - -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'. hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a) @@ -119,7 +109,7 @@ data DriverMessage where DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage -- | A parse error in parsing a Haskell file header during dependency -- analysis - DriverPsHeaderMessage :: !PsErrorDesc -> ![GhcHint] -> DriverMessage + DriverPsHeaderMessage :: !PsMessage -> DriverMessage {-| DriverMissingHomeModules is a warning (controlled with -Wmissing-home-modules) that arises when running GHC in --make mode when some modules needed for compilation diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index f0204246b6..e97fb5a4c6 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -145,8 +145,6 @@ import GHC.Core.FamInstEnv import GHC.CoreToStg.Prep import GHC.CoreToStg ( coreToStg ) -import GHC.Parser.Errors -import GHC.Parser.Errors.Ppr import GHC.Parser.Errors.Types import GHC.Parser import GHC.Parser.Lexer as Lexer @@ -233,7 +231,7 @@ import qualified Data.Set as S import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) -import Data.Bifunctor (first, bimap) +import Data.Bifunctor (first) {- ********************************************************************** %* * @@ -288,26 +286,21 @@ handleWarnings = do -- | log warning in the monad, and if there are errors then -- throw a SourceError exception. -logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () +logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do - dflags <- getDynFlags - let warns = foldPsMessages (mkParserWarn dflags) warnings - errs = foldPsMessages mkParserErr errors - logDiagnostics warns - when (not $ isEmptyMessages errs) $ throwErrors errs + logDiagnostics (GhcPsMessage <$> warnings) + when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors) -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed) -handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a +handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do dflags <- getDynFlags - let warns = foldPsMessages (mkParserWarn dflags) warnings - errs = foldPsMessages mkParserErr errors - logDiagnostics warns + logDiagnostics (GhcPsMessage <$> warnings) logger <- getLogger - let (wWarns, wErrs) = partitionMessages warns + let (wWarns, wErrs) = partitionMessages warnings liftIO $ printMessages logger dflags wWarns - throwErrors $ errs `unionMessages` wErrs + throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step -- @@ -418,11 +411,8 @@ hscParse' mod_summary PFailed pst -> handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do - let (warns, errs) = - bimap (foldPsMessages (mkParserWarn dflags)) - (foldPsMessages mkParserErr) - (getMessages pst) - logDiagnostics warns + let (warns, errs) = getMessages pst + logDiagnostics (GhcPsMessage <$> warns) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" @@ -431,7 +421,7 @@ hscParse' mod_summary rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) - when (not $ isEmptyMessages errs) $ throwErrors errs + when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) -- To get the list of extra source files, we take the list -- that the parser gave us, @@ -1618,10 +1608,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do $ do (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename - let msgs = foldPsMessages (mkParserWarn dflags) warns - `unionMessages` - foldPsMessages mkParserErr errs - return (msgs, cmm) + let msgs = warns `unionMessages` errs + return (GhcPsMessage <$> msgs, cmm) liftIO $ do dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 855675aa67..03803ecaf8 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -2818,7 +2818,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn - return (first (mkMessages . fmap mkDriverPsHeaderMessage) mimps) + return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) return PreprocessedImports {..} diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index f8ad427dc2..54221c4847 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -59,7 +59,6 @@ import GHC.Platform.Ways import GHC.Platform.ArchOS import GHC.Parser.Header -import GHC.Parser.Errors.Ppr import GHC.SysTools import GHC.Utils.TmpFs @@ -1248,7 +1247,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn popts = initParserOpts dflags eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of - Left errs -> throwErrors (foldPsMessages mkParserErr errs) + Left errs -> throwErrors (GhcPsMessage <$> errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index c89079ca70..363493482a 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -61,6 +61,7 @@ import GHC.Data.FastString import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GHC.Utils.Panic import GHC.Prelude @@ -84,7 +85,8 @@ import GHC.Parser.PostProcess import GHC.Parser.PostProcess.Haddock import GHC.Parser.Lexer import GHC.Parser.Annotation -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, @@ -809,7 +811,7 @@ HYPHEN :: { [AddEpAnn] } | PREFIX_MINUS { [mj AnnMinus $1 ] } | VARSYM {% if (getVARSYM $1 == fsLit "-") then return [mj AnnMinus $1] - else do { addError $ PsError PsErrExpectedHyphen [] (getLoc $1) + else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen ; return [] } } @@ -1126,7 +1128,8 @@ maybe_safe :: { (Maybe EpaLocation,Bool) } maybe_pkg :: { (Maybe EpaLocation,Maybe StringLiteral) } : STRING {% do { let { pkgFS = getSTRING $1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $ - addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1) + addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ + (PsErrInvalidPackageName pkgFS) ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } } | {- empty -} { (Nothing,Nothing) } @@ -1855,7 +1858,8 @@ rule_activation_marker :: { [AddEpAnn] } : PREFIX_TILDE { [mj AnnTilde $1] } | VARSYM {% if (getVARSYM $1 == fsLit "~") then return [mj AnnTilde $1] - else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1) + else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ + PsErrInvalidRuleActivationMarker ; return [] } } rule_explicit_activation :: { ([AddEpAnn] @@ -3275,8 +3279,8 @@ pat :: { LPat GhcPs } pat : exp {% (checkPattern <=< runPV) (unECP $1) } bindpat :: { LPat GhcPs } -bindpat : exp {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess - checkPattern_hints [SuggestMissingDo] +bindpat : exp {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess + checkPattern_details incompleteDoBlock (unECP $1) } apat :: { LPat GhcPs } @@ -3944,7 +3948,7 @@ getSCC :: Located Token -> P FastString getSCC lt = do let s = getSTRING lt -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s - then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt) + then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC else return s -- Utilities for combining source spans @@ -4085,7 +4089,7 @@ fileSrcSpan = do hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do linearEnabled <- getBit LinearTypesBit - unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span + unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction -- Does this look like (a %m)? looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool @@ -4104,14 +4108,15 @@ looksLikeMult ty1 l_op ty2 hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit - unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span + unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit - unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok) + unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + (PsErrExplicitForall (isUnicode tok)) -- Hint about qualified-do hintQualifiedDo :: Located Token -> P () @@ -4119,7 +4124,8 @@ hintQualifiedDo tok = do qualifiedDo <- getBit QualifiedDoBit case maybeQDoDoc of Just qdoDoc | not qualifiedDo -> - addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok) + addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + (PsErrIllegalQualifiedDo qdoDoc) _ -> return () where maybeQDoDoc = case unLoc tok of @@ -4133,7 +4139,7 @@ hintQualifiedDo tok = do reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit - addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span + addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes {- %************************************************************************ diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs deleted file mode 100644 index 7a9c154ed8..0000000000 --- a/compiler/GHC/Parser/Errors.hs +++ /dev/null @@ -1,421 +0,0 @@ -module GHC.Parser.Errors - ( PsWarning(..) - , TransLayoutReason(..) - , OperatorWhitespaceSymbol(..) - , OperatorWhitespaceOccurrence(..) - , NumUnderscoreReason(..) - , PsError(..) - , PsErrorDesc(..) - , LexErr(..) - , CmmParserError(..) - , LexErrKind(..) - , StarIsType (..) - ) -where - -import GHC.Prelude -import GHC.Types.Error -import GHC.Types.SrcLoc -import GHC.Types.Name.Reader (RdrName) -import GHC.Types.Name.Occurrence (OccName) -import GHC.Parser.Types -import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension -import GHC.Hs.Expr -import GHC.Hs.Pat -import GHC.Hs.Type -import GHC.Hs.Lit -import GHC.Hs.Decls -import GHC.Core.Coercion.Axiom (Role) -import GHC.Data.FastString -import GHC.Unit.Module.Name - --- | A warning that might arise during parsing. -data PsWarning - - -- | Warn when tabulations are found - = PsWarnTab - { tabFirst :: !SrcSpan -- ^ First occurrence of a tab - , tabCount :: !Word -- ^ Number of other occurrences - } - - | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason - -- ^ Transitional layout warnings - - | PsWarnUnrecognisedPragma !SrcSpan - -- ^ Unrecognised pragma - - | PsWarnHaddockInvalidPos !SrcSpan - -- ^ Invalid Haddock comment position - - | PsWarnHaddockIgnoreMulti !SrcSpan - -- ^ Multiple Haddock comment for the same entity - - | PsWarnStarBinder !SrcSpan - -- ^ Found binding occurrence of "*" while StarIsType is enabled - - | PsWarnStarIsType !SrcSpan - -- ^ Using "*" for "Type" without StarIsType enabled - - | PsWarnImportPreQualified !SrcSpan - -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled - - | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol - | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence - --- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning. -data OperatorWhitespaceSymbol - = OperatorWhitespaceSymbol_PrefixPercent - | OperatorWhitespaceSymbol_PrefixDollar - | OperatorWhitespaceSymbol_PrefixDollarDollar - --- | The operator occurrence type in the 'WarnOperatorWhitespace' warning. -data OperatorWhitespaceOccurrence - = OperatorWhitespaceOccurrence_Prefix - | OperatorWhitespaceOccurrence_Suffix - | OperatorWhitespaceOccurrence_TightInfix - -data TransLayoutReason - = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block" - | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block") - -data PsError = PsError - { errDesc :: !PsErrorDesc -- ^ Error description - , errHints :: ![GhcHint] -- ^ Hints - , errLoc :: !SrcSpan -- ^ Error position - } - -data PsErrorDesc - = PsErrLambdaCase - -- ^ LambdaCase syntax used without the extension enabled - - | PsErrEmptyLambda - -- ^ A lambda requires at least one parameter - - | PsErrNumUnderscores !NumUnderscoreReason - -- ^ Underscores in literals without the extension enabled - - | PsErrPrimStringInvalidChar - -- ^ Invalid character in primitive string - - | PsErrMissingBlock - -- ^ Missing block - - | PsErrLexer !LexErr !LexErrKind - -- ^ Lexer error - - | PsErrSuffixAT - -- ^ Suffix occurrence of `@` - - | PsErrParse !String - -- ^ Parse errors - - | PsErrCmmLexer - -- ^ Cmm lexer error - - | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs)) - -- ^ Unsupported boxed sum in expression - - | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs)) - -- ^ Unsupported boxed sum in pattern - - | PsErrUnexpectedQualifiedConstructor !RdrName - -- ^ Unexpected qualified constructor - - | PsErrTupleSectionInPat - -- ^ Tuple section in pattern context - - | PsErrIllegalBangPattern !(Pat GhcPs) - -- ^ Bang-pattern without BangPattterns enabled - - | PsErrOpFewArgs !StarIsType !RdrName - -- ^ Operator applied to too few arguments - - | PsErrImportQualifiedTwice - -- ^ Import: multiple occurrences of 'qualified' - - | PsErrImportPostQualified - -- ^ Post qualified import without 'ImportQualifiedPost' - - | PsErrIllegalExplicitNamespace - -- ^ Explicit namespace keyword without 'ExplicitNamespaces' - - | PsErrVarForTyCon !RdrName - -- ^ Expecting a type constructor but found a variable - - | PsErrIllegalPatSynExport - -- ^ Illegal export form allowed by PatternSynonyms - - | PsErrMalformedEntityString - -- ^ Malformed entity string - - | PsErrDotsInRecordUpdate - -- ^ Dots used in record update - - | PsErrPrecedenceOutOfRange !Int - -- ^ Precedence out of range - - | PsErrOverloadedRecordDotInvalid - -- ^ Invalid use of record dot syntax `.' - - | PsErrOverloadedRecordUpdateNotEnabled - -- ^ `OverloadedRecordUpdate` is not enabled. - - | PsErrOverloadedRecordUpdateNoQualifiedFields - -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled. - - | PsErrInvalidDataCon !(HsType GhcPs) - -- ^ Cannot parse data constructor in a data/newtype declaration - - | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs) - -- ^ Cannot parse data constructor in a data/newtype declaration - - | PsErrUnpackDataCon - -- ^ UNPACK applied to a data constructor - - | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs) - -- ^ Unexpected kind application in data/newtype declaration - - | PsErrInvalidRecordCon !(PatBuilder GhcPs) - -- ^ Not a record constructor - - | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs) - -- ^ Illegal unboxed string literal in pattern - - | PsErrDoNotationInPat - -- ^ Do-notation in pattern - - | PsErrIfTheElseInPat - -- ^ If-then-else syntax in pattern - - | PsErrLambdaCaseInPat - -- ^ Lambda-case in pattern - - | PsErrCaseInPat - -- ^ case..of in pattern - - | PsErrLetInPat - -- ^ let-syntax in pattern - - | PsErrLambdaInPat - -- ^ Lambda-syntax in pattern - - | PsErrArrowExprInPat !(HsExpr GhcPs) - -- ^ Arrow expression-syntax in pattern - - | PsErrArrowCmdInPat !(HsCmd GhcPs) - -- ^ Arrow command-syntax in pattern - - | PsErrArrowCmdInExpr !(HsCmd GhcPs) - -- ^ Arrow command-syntax in expression - - | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs) - -- ^ View-pattern in expression - - | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) - -- ^ Type-application without space before '@' - - | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs) - -- ^ Lazy-pattern ('~') without space after it - - | PsErrBangPatWithoutSpace !(LHsExpr GhcPs) - -- ^ Bang-pattern ('!') without space after it - - | PsErrUnallowedPragma !(HsPragE GhcPs) - -- ^ Pragma not allowed in this position - - | PsErrQualifiedDoInCmd !ModuleName - -- ^ Qualified do block in command - - | PsErrInvalidInfixHole - -- ^ Invalid infix hole, expected an infix operator - - | PsErrSemiColonsInCondExpr - -- ^ Unexpected semi-colons in conditional expression - !(HsExpr GhcPs) -- ^ conditional expr - !Bool -- ^ "then" semi-colon? - !(HsExpr GhcPs) -- ^ "then" expr - !Bool -- ^ "else" semi-colon? - !(HsExpr GhcPs) -- ^ "else" expr - - | PsErrSemiColonsInCondCmd - -- ^ Unexpected semi-colons in conditional command - !(HsExpr GhcPs) -- ^ conditional expr - !Bool -- ^ "then" semi-colon? - !(HsCmd GhcPs) -- ^ "then" expr - !Bool -- ^ "else" semi-colon? - !(HsCmd GhcPs) -- ^ "else" expr - - | PsErrAtInPatPos - -- ^ @-operator in a pattern position - - | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs) - -- ^ Unexpected lambda command in function application - - | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) - -- ^ Unexpected case command in function application - - | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs) - -- ^ Unexpected if command in function application - - | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs) - -- ^ Unexpected let command in function application - - | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs) - -- ^ Unexpected do command in function application - - | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) - -- ^ Unexpected do block in function application - - | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) - -- ^ Unexpected mdo block in function application - - | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected lambda expression in function application - - | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected case expression in function application - - | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected lambda-case expression in function application - - | PsErrLetInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected let expression in function application - - | PsErrIfInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected if expression in function application - - | PsErrProcInFunAppExpr !(LHsExpr GhcPs) - -- ^ Unexpected proc expression in function application - - | PsErrMalformedTyOrClDecl !(LHsType GhcPs) - -- ^ Malformed head of type or class declaration - - | PsErrIllegalWhereInDataDecl - -- ^ Illegal 'where' keyword in data declaration - - | PsErrIllegalDataTypeContext !(LHsContext GhcPs) - -- ^ Illegal datatyp context - - | PsErrParseErrorOnInput !OccName - -- ^ Parse error on input - - | PsErrMalformedDecl !SDoc !RdrName - -- ^ Malformed ... declaration for ... - - | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName - -- ^ Unexpected type application in a declaration - - | PsErrNotADataCon !RdrName - -- ^ Not a data constructor - - | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs) - -- ^ Record syntax used in pattern synonym declaration - - | PsErrEmptyWhereInPatSynDecl !RdrName - -- ^ Empty 'where' clause in pattern-synonym declaration - - | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) - -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration - - | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) - -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration - - | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs) - -- ^ Declaration splice not a top-level - - | PsErrInferredTypeVarNotAllowed - -- ^ Inferred type variables not allowed here - - | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs] - -- ^ Multiple names in standalone kind signatures - - | PsErrIllegalImportBundleForm - -- ^ Illegal import bundle form - - | PsErrIllegalRoleName !FastString [Role] - -- ^ Illegal role name - - | PsErrInvalidTypeSignature !(LHsExpr GhcPs) - -- ^ Invalid type signature - - | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc - -- ^ Unexpected type in declaration - - | PsErrExpectedHyphen - -- ^ Expected a hyphen - - | PsErrSpaceInSCC - -- ^ Found a space in a SCC - - | PsErrEmptyDoubleQuotes !Bool-- Is TH on? - -- ^ Found two single quotes - - | PsErrInvalidPackageName !FastString - -- ^ Invalid package name - - | PsErrInvalidRuleActivationMarker - -- ^ Invalid rule activation marker - - | PsErrLinearFunction - -- ^ Linear function found but LinearTypes not enabled - - | PsErrMultiWayIf - -- ^ Multi-way if-expression found but MultiWayIf not enabled - - | PsErrExplicitForall !Bool -- is Unicode forall? - -- ^ Explicit forall found but no extension allowing it is enabled - - | PsErrIllegalQualifiedDo !SDoc - -- ^ Found qualified-do without QualifiedDo enabled - - | PsErrCmmParser !CmmParserError - -- ^ Cmm parser error - - | PsErrIllegalTraditionalRecordSyntax !SDoc - -- ^ Illegal traditional record syntax - -- - -- TODO: distinguish errors without using SDoc - - | PsErrParseErrorInCmd !SDoc - -- ^ Parse error in command - -- - -- TODO: distinguish errors without using SDoc - - | PsErrParseErrorInPat !SDoc - -- ^ Parse error in pattern - -- - -- TODO: distinguish errors without using SDoc - - -newtype StarIsType = StarIsType Bool - -data NumUnderscoreReason - = NumUnderscore_Integral - | NumUnderscore_Float - deriving (Show,Eq,Ord) - -data LexErrKind - = LexErrKind_EOF -- ^ End of input - | LexErrKind_UTF8 -- ^ UTF-8 decoding error - | LexErrKind_Char !Char -- ^ Error at given character - deriving (Show,Eq,Ord) - -data LexErr - = LexError -- ^ Lexical error - | LexUnknownPragma -- ^ Unknown pragma - | LexErrorInPragma -- ^ Lexical error in pragma - | LexNumEscapeRange -- ^ Numeric escape sequence out of range - | LexStringCharLit -- ^ Llexical error in string/character literal - | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal - | LexUnterminatedComment -- ^ Unterminated `{-' - | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma - | LexUnterminatedQQ -- ^ Unterminated quasiquotation - --- | Errors from the Cmm parser -data CmmParserError - = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive - | CmmUnknownMacro !FastString -- ^ Unknown macro - | CmmUnknownCConv !String -- ^ Unknown calling convention - | CmmUnrecognisedSafety !String -- ^ Unrecognised safety - | CmmUnrecognisedHint !String -- ^ Unrecognised hint diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 4cc8da75f4..6a2152f3f7 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -1,528 +1,479 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage -module GHC.Parser.Errors.Ppr - ( mkParserWarn - , mkParserErr - , pprPsError - ) -where +module GHC.Parser.Errors.Ppr where import GHC.Prelude import GHC.Driver.Flags -import GHC.Parser.Errors import GHC.Parser.Errors.Types import GHC.Parser.Types import GHC.Types.Basic import GHC.Types.Error -import GHC.Types.Hint (perhapsAsPat) import GHC.Types.SrcLoc -import GHC.Types.Name.Reader (starInfo, rdrNameOcc, mkUnqual) +import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Data.FastString +import GHC.Data.Maybe (catMaybes) import GHC.Hs.Expr (prependQualified,HsExpr(..)) import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -import GHC.Driver.Session (DynFlags) -import GHC.Utils.Error (diagReasonSeverity) +import qualified GHC.LanguageExtensions as LangExt -instance Diagnostic PsMessage where - diagnosticMessage (PsUnknownMessage m) = diagnosticMessage m - diagnosticReason (PsUnknownMessage m) = diagnosticReason m - -- FIXME(adinapoli) Fix it properly for #18516. - -- The reason why we temporarily set 'diagnosticHints' to be - -- the empty list is because currently the parser types does - -- not integrate tightly with the new diagnostic infrastructure - -- and as such hints and bundled together with the rendereded - -- diagnostic, and the same 'PsErrorDesc' is sometimes emitted - -- twice but with a different hint, which makes it hard to - -- untangle the two. Therefore, to smooth out the integration, - -- we provisionally tuck the hints directly into a 'PsUnknownMessage' - -- and we rendered them inside 'diagnosticMessage'. - diagnosticHints (PsUnknownMessage _m) = [] - -mk_parser_err :: [GhcHint] -> SrcSpan -> SDoc -> MsgEnvelope PsMessage -mk_parser_err hints span doc = MsgEnvelope - { errMsgSpan = span - , errMsgContext = alwaysQualify - , errMsgDiagnostic = PsUnknownMessage $ mkPlainError hints doc - , errMsgSeverity = SevError - } - -mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope PsMessage -mk_parser_warn df flag span doc = MsgEnvelope - { errMsgSpan = span - , errMsgContext = alwaysQualify - , errMsgDiagnostic = PsUnknownMessage $ mkPlainDiagnostic reason noHints doc - , errMsgSeverity = diagReasonSeverity df reason - } - where - reason :: DiagnosticReason - reason = WarningWithFlag flag -mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope PsMessage -mkParserWarn df = \case - PsWarnTab loc tc - -> mk_parser_warn df Opt_WarnTabs loc $ - text "Tab character found here" - <> (if tc == 1 - then text "" - else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location")) - <> text "." - $+$ text "Please use spaces instead." - - PsWarnTransitionalLayout loc reason - -> mk_parser_warn df Opt_WarnAlternativeLayoutRuleTransitional loc $ +instance Diagnostic PsMessage where + diagnosticMessage = \case + PsUnknownMessage m + -> diagnosticMessage m + + PsWarnHaddockInvalidPos + -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored." + PsWarnHaddockIgnoreMulti + -> mkSimpleDecorated $ + text "Multiple Haddock comments for a single entity are not allowed." $$ + text "The extraneous comment will be ignored." + PsWarnTab tc + -> mkSimpleDecorated $ + text "Tab character found here" + <> (if tc == 1 + then text "" + else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location")) + <> text "." + PsWarnTransitionalLayout reason + -> mkSimpleDecorated $ text "transitional layout will not be accepted in the future:" $$ text (case reason of TransLayout_Where -> "`where' clause at the same depth as implicit layout block" TransLayout_Pipe -> "`|' at the same depth as implicit layout block" ) - - PsWarnUnrecognisedPragma loc - -> mk_parser_warn df Opt_WarnUnrecognisedPragmas loc $ - text "Unrecognised pragma" - - PsWarnHaddockInvalidPos loc - -> mk_parser_warn df Opt_WarnInvalidHaddock loc $ - text "A Haddock comment cannot appear in this position and will be ignored." - - PsWarnHaddockIgnoreMulti loc - -> mk_parser_warn df Opt_WarnInvalidHaddock loc $ - text "Multiple Haddock comments for a single entity are not allowed." $$ - text "The extraneous comment will be ignored." - - PsWarnStarBinder loc - -> mk_parser_warn df Opt_WarnStarBinder loc $ - text "Found binding occurrence of" <+> quotes (text "*") - <+> text "yet StarIsType is enabled." - $$ text "NB. To use (or export) this operator in" - <+> text "modules with StarIsType," - $$ text " including the definition module, you must qualify it." - - PsWarnStarIsType loc - -> mk_parser_warn df Opt_WarnStarIsType loc $ - text "Using" <+> quotes (text "*") - <+> text "(or its Unicode variant) to mean" - <+> quotes (text "Data.Kind.Type") - $$ text "relies on the StarIsType extension, which will become" - $$ text "deprecated in the future." - $$ text "Suggested fix: use" <+> quotes (text "Type") - <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." - - PsWarnImportPreQualified loc - -> mk_parser_warn df Opt_WarnPrepositiveQualifiedModule loc $ - text "Found" <+> quotes (text "qualified") - <+> text "in prepositive position" - $$ text "Suggested fix: place " <+> quotes (text "qualified") - <+> text "after the module name instead." - $$ text "To allow this, enable language extension 'ImportQualifiedPost'" - - PsWarnOperatorWhitespaceExtConflict loc sym - -> mk_parser_warn df Opt_WarnOperatorWhitespaceExtConflict loc $ - let mk_prefix_msg operator_symbol extension_name syntax_meaning = + PsWarnOperatorWhitespaceExtConflict sym + -> let mk_prefix_msg operator_symbol extension_name syntax_meaning = text "The prefix use of a" <+> quotes (text operator_symbol) <+> text "would denote" <+> text syntax_meaning $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.") $$ text "Suggested fix: add whitespace after the" <+> quotes (text operator_symbol) <> char '.' - in + in mkSimpleDecorated $ case sym of OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation" OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice" OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice" - - - PsWarnOperatorWhitespace loc sym occ_type - -> mk_parser_warn df Opt_WarnOperatorWhitespace loc $ - let mk_msg occ_type_str = + PsWarnOperatorWhitespace sym occ_type + -> let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) <+> text "might be repurposed as special syntax" $$ nest 2 (text "by a future language extension.") $$ text "Suggested fix: add whitespace around it." - in + in mkSimpleDecorated $ case occ_type of OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix" OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" + PsWarnStarBinder + -> mkSimpleDecorated $ + text "Found binding occurrence of" <+> quotes (text "*") + <+> text "yet StarIsType is enabled." + $$ text "NB. To use (or export) this operator in" + <+> text "modules with StarIsType," + $$ text " including the definition module, you must qualify it." + PsWarnStarIsType + -> mkSimpleDecorated $ + text "Using" <+> quotes (text "*") + <+> text "(or its Unicode variant) to mean" + <+> quotes (text "Data.Kind.Type") + $$ text "relies on the StarIsType extension, which will become" + $$ text "deprecated in the future." + $$ text "Suggested fix: use" <+> quotes (text "Type") + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + PsWarnUnrecognisedPragma + -> mkSimpleDecorated $ text "Unrecognised pragma" + PsWarnImportPreQualified + -> mkSimpleDecorated $ + text "Found" <+> quotes (text "qualified") + <+> text "in prepositive position" + $$ text "Suggested fix: place " <+> quotes (text "qualified") + <+> text "after the module name instead." + $$ text "To allow this, enable language extension 'ImportQualifiedPost'" -mkParserErr :: PsError -> MsgEnvelope PsMessage -mkParserErr err = mk_parser_err (errHints err) (errLoc err) $ - pprPsError (errDesc err) (errHints err) - --- | Render a 'PsErrorDesc' into an 'SDoc', with its 'Hint's. -pprPsError :: PsErrorDesc -> [GhcHint] -> SDoc -pprPsError desc hints = vcat (pp_err desc : map ppr hints) - -pp_err :: PsErrorDesc -> SDoc -pp_err = \case - PsErrLambdaCase - -> text "Illegal lambda-case (use LambdaCase)" - - PsErrEmptyLambda - -> text "A lambda requires at least one parameter" - - PsErrNumUnderscores reason - -> text $ case reason of - NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals" - NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals" - - PsErrPrimStringInvalidChar - -> text "primitive string literal must contain only characters <= \'\\xFF\'" - - PsErrMissingBlock - -> text "Missing block" - - PsErrLexer err kind - -> hcat - [ text $ case err of - LexError -> "lexical error" - LexUnknownPragma -> "unknown pragma" - LexErrorInPragma -> "lexical error in pragma" - LexNumEscapeRange -> "numeric escape sequence out of range" - LexStringCharLit -> "lexical error in string/character literal" - LexStringCharLitEOF -> "unexpected end-of-file in string/character literal" - LexUnterminatedComment -> "unterminated `{-'" - LexUnterminatedOptions -> "unterminated OPTIONS pragma" - LexUnterminatedQQ -> "unterminated quasiquotation" - - - , text $ case kind of - LexErrKind_EOF -> " at end of input" - LexErrKind_UTF8 -> " (UTF-8 decoding error)" - LexErrKind_Char c -> " at character " ++ show c - ] - - PsErrSuffixAT - -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." - - PsErrParse token + PsErrLexer err kind + -> mkSimpleDecorated $ hcat + [ text $ case err of + LexError -> "lexical error" + LexUnknownPragma -> "unknown pragma" + LexErrorInPragma -> "lexical error in pragma" + LexNumEscapeRange -> "numeric escape sequence out of range" + LexStringCharLit -> "lexical error in string/character literal" + LexStringCharLitEOF -> "unexpected end-of-file in string/character literal" + LexUnterminatedComment -> "unterminated `{-'" + LexUnterminatedOptions -> "unterminated OPTIONS pragma" + LexUnterminatedQQ -> "unterminated quasiquotation" + + , text $ case kind of + LexErrKind_EOF -> " at end of input" + LexErrKind_UTF8 -> " (UTF-8 decoding error)" + LexErrKind_Char c -> " at character " ++ show c + ] + PsErrParse token _details | null token - -> text "parse error (possibly incorrect indentation or mismatched brackets)" - + -> mkSimpleDecorated $ text "parse error (possibly incorrect indentation or mismatched brackets)" | otherwise - -> text "parse error on input" <+> quotes (text token) - - PsErrCmmLexer - -> text "Cmm lexical error" - - PsErrUnsupportedBoxedSumExpr s - -> hang (text "Boxed sums not supported:") 2 - (pprSumOrTuple Boxed s) - - PsErrUnsupportedBoxedSumPat s - -> hang (text "Boxed sums not supported:") 2 - (pprSumOrTuple Boxed s) - - PsErrUnexpectedQualifiedConstructor v - -> hang (text "Expected an unqualified type constructor:") 2 - (ppr v) - - PsErrTupleSectionInPat - -> text "Tuple section in pattern context" - - PsErrIllegalBangPattern e - -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e - - PsErrOpFewArgs (StarIsType star_is_type) op - -> text "Operator applied to too few arguments:" <+> ppr op - $$ starInfo star_is_type op - - PsErrImportQualifiedTwice - -> text "Multiple occurrences of 'qualified'" - - PsErrImportPostQualified - -> text "Found" <+> quotes (text "qualified") - <+> text "in postpositive position. " - $$ text "To allow this, enable language extension 'ImportQualifiedPost'" - - PsErrIllegalExplicitNamespace - -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" - - PsErrVarForTyCon name - -> text "Expecting a type constructor but found a variable," - <+> quotes (ppr name) <> text "." - $$ if isSymOcc $ rdrNameOcc name - then text "If" <+> quotes (ppr name) <+> text "is a type constructor" - <+> text "then enable ExplicitNamespaces and use the 'type' keyword." - else empty - - PsErrIllegalPatSynExport - -> text "Illegal export form (use PatternSynonyms to enable)" - - PsErrMalformedEntityString - -> text "Malformed entity string" - - PsErrDotsInRecordUpdate - -> text "You cannot use `..' in a record update" - - PsErrPrecedenceOutOfRange i - -> text "Precedence out of range: " <> int i - - PsErrOverloadedRecordDotInvalid - -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" - - PsErrOverloadedRecordUpdateNoQualifiedFields - -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled" - - PsErrOverloadedRecordUpdateNotEnabled - -> text "OverloadedRecordUpdate needs to be enabled" - - PsErrInvalidDataCon t - -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 - (ppr t) - - PsErrInvalidInfixDataCon lhs tc rhs - -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") - 2 (ppr lhs <+> ppr tc <+> ppr rhs) - - PsErrUnpackDataCon - -> text "{-# UNPACK #-} cannot be applied to a data constructor." - - PsErrUnexpectedKindAppInDataCon lhs ki - -> hang (text "Unexpected kind application in a data/newtype declaration:") 2 - (ppr lhs <+> text "@" <> ppr ki) - - PsErrInvalidRecordCon p - -> text "Not a record constructor:" <+> ppr p - - PsErrIllegalUnboxedStringInPat lit - -> text "Illegal unboxed string literal in pattern:" $$ ppr lit - - PsErrDoNotationInPat - -> text "do-notation in pattern" - - PsErrIfTheElseInPat - -> text "(if ... then ... else ...)-syntax in pattern" - - PsErrLambdaCaseInPat - -> text "(\\case ...)-syntax in pattern" - - PsErrCaseInPat - -> text "(case ... of ...)-syntax in pattern" - - PsErrLetInPat - -> text "(let ... in ...)-syntax in pattern" - - PsErrLambdaInPat - -> text "Lambda-syntax in pattern." - $$ text "Pattern matching on functions is not possible." - - PsErrArrowExprInPat e - -> text "Expression syntax in pattern:" <+> ppr e - - PsErrArrowCmdInPat c - -> text "Command syntax in pattern:" <+> ppr c - - PsErrArrowCmdInExpr c - -> vcat - [ text "Arrow command found where an expression was expected:" - , nest 2 (ppr c) - ] - - PsErrViewPatInExpr a b - -> sep [ text "View pattern in expression context:" - , nest 4 (ppr a <+> text "->" <+> ppr b) - ] - - PsErrTypeAppWithoutSpace v e - -> sep [ text "@-pattern in expression context:" - , nest 4 (pprPrefixOcc v <> text "@" <> ppr e) - ] - $$ text "Type application syntax requires a space before '@'" - - - PsErrLazyPatWithoutSpace e - -> sep [ text "Lazy pattern in expression context:" - , nest 4 (text "~" <> ppr e) - ] - $$ text "Did you mean to add a space after the '~'?" - - PsErrBangPatWithoutSpace e - -> sep [ text "Bang pattern in expression context:" - , nest 4 (text "!" <> ppr e) - ] - $$ text "Did you mean to add a space after the '!'?" - - PsErrUnallowedPragma prag - -> hang (text "A pragma is not allowed in this position:") 2 - (ppr prag) - - PsErrQualifiedDoInCmd m - -> hang (text "Parse error in command:") 2 $ - text "Found a qualified" <+> ppr m <> text ".do block in a command, but" - $$ text "qualified 'do' is not supported in commands." - - PsErrParseErrorInCmd s - -> hang (text "Parse error in command:") 2 s - - PsErrParseErrorInPat s - -> text "Parse error in pattern:" <+> s - + -> mkSimpleDecorated $ text "parse error on input" <+> quotes (text token) + PsErrCmmLexer + -> mkSimpleDecorated $ text "Cmm lexical error" + PsErrCmmParser cmm_err -> mkSimpleDecorated $ case cmm_err of + CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name + CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun + CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv + CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety + CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint - PsErrInvalidInfixHole - -> text "Invalid infix hole, expected an infix operator" + PsErrTypeAppWithoutSpace v e + -> mkSimpleDecorated $ + sep [ text "@-pattern in expression context:" + , nest 4 (pprPrefixOcc v <> text "@" <> ppr e) + ] + $$ text "Type application syntax requires a space before '@'" + PsErrLazyPatWithoutSpace e + -> mkSimpleDecorated $ + sep [ text "Lazy pattern in expression context:" + , nest 4 (text "~" <> ppr e) + ] + $$ text "Did you mean to add a space after the '~'?" + PsErrBangPatWithoutSpace e + -> mkSimpleDecorated $ + sep [ text "Bang pattern in expression context:" + , nest 4 (text "!" <> ppr e) + ] + $$ text "Did you mean to add a space after the '!'?" + PsErrInvalidInfixHole + -> mkSimpleDecorated $ text "Invalid infix hole, expected an infix operator" + PsErrExpectedHyphen + -> mkSimpleDecorated $ text "Expected a hyphen" + PsErrSpaceInSCC + -> mkSimpleDecorated $ text "Spaces are not allowed in SCCs" + PsErrEmptyDoubleQuotes th_on + -> mkSimpleDecorated $ if th_on then vcat (msg ++ th_msg) else vcat msg + where + msg = [ text "Parser error on `''`" + , text "Character literals may not be empty" + ] + th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell," + , text "but the type variable or constructor is missing" + ] - PsErrSemiColonsInCondExpr c st t se e - -> text "Unexpected semi-colons in conditional:" - $$ nest 4 expr - $$ text "Perhaps you meant to use DoAndIfThenElse?" + PsErrLambdaCase + -> mkSimpleDecorated $ text "Illegal lambda-case (use LambdaCase)" + PsErrEmptyLambda + -> mkSimpleDecorated $ text "A lambda requires at least one parameter" + PsErrLinearFunction + -> mkSimpleDecorated $ text "Enable LinearTypes to allow linear functions" + PsErrOverloadedRecordUpdateNotEnabled + -> mkSimpleDecorated $ text "OverloadedRecordUpdate needs to be enabled" + PsErrMultiWayIf + -> mkSimpleDecorated $ text "Multi-way if-expressions need MultiWayIf turned on" + PsErrNumUnderscores reason + -> mkSimpleDecorated $ + text $ case reason of + NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals" + NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals" + PsErrIllegalBangPattern e + -> mkSimpleDecorated $ text "Illegal bang-pattern (use BangPatterns):" $$ ppr e + PsErrOverloadedRecordDotInvalid + -> mkSimpleDecorated $ + text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" + PsErrIllegalPatSynExport + -> mkSimpleDecorated $ text "Illegal export form (use PatternSynonyms to enable)" + PsErrOverloadedRecordUpdateNoQualifiedFields + -> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled" + PsErrExplicitForall is_unicode + -> mkSimpleDecorated $ vcat + [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type" + , text "Perhaps you intended to use RankNTypes or a similar language" + , text "extension to enable explicit-forall syntax:" <+> + forallSym is_unicode <+> text "<tvs>. <type>" + ] + where + forallSym True = text "∀" + forallSym False = text "forall" + PsErrIllegalQualifiedDo qdoDoc + -> mkSimpleDecorated $ vcat + [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block" + , text "Perhaps you intended to use QualifiedDo" + ] + PsErrQualifiedDoInCmd m + -> mkSimpleDecorated $ + hang (text "Parse error in command:") 2 $ + text "Found a qualified" <+> ppr m <> text ".do block in a command, but" + $$ text "qualified 'do' is not supported in commands." + PsErrRecordSyntaxInPatSynDecl pat + -> mkSimpleDecorated $ + text "record syntax not supported for pattern synonym declarations:" + $$ ppr pat + PsErrEmptyWhereInPatSynDecl patsyn_name + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause cannot be empty" + $$ text "In the pattern synonym declaration for: " + <+> ppr (patsyn_name) + PsErrInvalidWhereBindInPatSynDecl patsyn_name decl + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl + PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause must contain a single binding:" + $$ ppr decl + PsErrDeclSpliceNotAtTopLevel d + -> mkSimpleDecorated $ + hang (text "Declaration splices are allowed only" + <+> text "at the top level:") + 2 (ppr d) + PsErrMultipleNamesInStandaloneKindSignature vs + -> mkSimpleDecorated $ + vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") + 2 (pprWithCommas ppr vs) + , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." + ] + PsErrIllegalExplicitNamespace + -> mkSimpleDecorated $ + text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" + + PsErrUnallowedPragma prag + -> mkSimpleDecorated $ + hang (text "A pragma is not allowed in this position:") 2 + (ppr prag) + PsErrImportPostQualified + -> mkSimpleDecorated $ + text "Found" <+> quotes (text "qualified") + <+> text "in postpositive position. " + $$ text "To allow this, enable language extension 'ImportQualifiedPost'" + PsErrImportQualifiedTwice + -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'" + PsErrIllegalImportBundleForm + -> mkSimpleDecorated $ + text "Illegal import form, this syntax can only be used to bundle" + $+$ text "pattern synonyms with types in module exports." + PsErrInvalidRuleActivationMarker + -> mkSimpleDecorated $ text "Invalid rule activation marker" + + PsErrMissingBlock + -> mkSimpleDecorated $ text "Missing block" + PsErrUnsupportedBoxedSumExpr s + -> mkSimpleDecorated $ + hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed s) + PsErrUnsupportedBoxedSumPat s + -> mkSimpleDecorated $ + hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed s) + PsErrUnexpectedQualifiedConstructor v + -> mkSimpleDecorated $ + hang (text "Expected an unqualified type constructor:") 2 + (ppr v) + PsErrTupleSectionInPat + -> mkSimpleDecorated $ text "Tuple section in pattern context" + PsErrOpFewArgs (StarIsType star_is_type) op + -> mkSimpleDecorated $ + text "Operator applied to too few arguments:" <+> ppr op + $$ starInfo star_is_type op + PsErrVarForTyCon name + -> mkSimpleDecorated $ + text "Expecting a type constructor but found a variable," + <+> quotes (ppr name) <> text "." + $$ if isSymOcc $ rdrNameOcc name + then text "If" <+> quotes (ppr name) <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + else empty + PsErrMalformedEntityString + -> mkSimpleDecorated $ text "Malformed entity string" + PsErrDotsInRecordUpdate + -> mkSimpleDecorated $ text "You cannot use `..' in a record update" + PsErrInvalidDataCon t + -> mkSimpleDecorated $ + hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 + (ppr t) + PsErrInvalidInfixDataCon lhs tc rhs + -> mkSimpleDecorated $ + hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2 + (ppr lhs <+> ppr tc <+> ppr rhs) + PsErrUnpackDataCon + -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor." + PsErrUnexpectedKindAppInDataCon lhs ki + -> mkSimpleDecorated $ + hang (text "Unexpected kind application in a data/newtype declaration:") 2 + (ppr lhs <+> text "@" <> ppr ki) + PsErrInvalidRecordCon p + -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p + PsErrIllegalUnboxedStringInPat lit + -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit + PsErrDoNotationInPat + -> mkSimpleDecorated $ text "do-notation in pattern" + PsErrIfThenElseInPat + -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern" + PsErrLambdaCaseInPat + -> mkSimpleDecorated $ text "(\\case ...)-syntax in pattern" + PsErrCaseInPat + -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern" + PsErrLetInPat + -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern" + PsErrLambdaInPat + -> mkSimpleDecorated $ + text "Lambda-syntax in pattern." + $$ text "Pattern matching on functions is not possible." + PsErrArrowExprInPat e + -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e + PsErrArrowCmdInPat c + -> mkSimpleDecorated $ text "Command syntax in pattern:" <+> ppr c + PsErrArrowCmdInExpr c + -> mkSimpleDecorated $ + vcat + [ text "Arrow command found where an expression was expected:" + , nest 2 (ppr c) + ] + PsErrViewPatInExpr a b + -> mkSimpleDecorated $ + sep [ text "View pattern in expression context:" + , nest 4 (ppr a <+> text "->" <+> ppr b) + ] + PsErrLambdaCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a + PsErrCaseCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a + PsErrIfCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a + PsErrLetCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let command") a + PsErrDoCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "do command") a + PsErrDoInFunAppExpr m a + -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a + PsErrMDoInFunAppExpr m a + -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a + PsErrLambdaInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a + PsErrCaseInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a + PsErrLambdaCaseInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda-case expression") a + PsErrLetInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a + PsErrIfInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if expression") a + PsErrProcInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "proc expression") a + PsErrMalformedTyOrClDecl ty + -> mkSimpleDecorated $ + text "Malformed head of type or class declaration:" <+> ppr ty + PsErrIllegalWhereInDataDecl + -> mkSimpleDecorated $ + vcat + [ text "Illegal keyword 'where' in data declaration" + , text "Perhaps you intended to use GADTs or a similar language" + , text "extension to enable syntax: data T where" + ] + PsErrIllegalDataTypeContext c + -> mkSimpleDecorated $ + text "Illegal datatype context (use DatatypeContexts):" + <+> pprLHsContext (Just c) + PsErrPrimStringInvalidChar + -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'" + PsErrSuffixAT + -> mkSimpleDecorated $ + text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." + PsErrPrecedenceOutOfRange i + -> mkSimpleDecorated $ text "Precedence out of range: " <> int i + PsErrSemiColonsInCondExpr c st t se e + -> mkSimpleDecorated $ + text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use DoAndIfThenElse?" where pprOptSemi True = semi pprOptSemi False = empty expr = text "if" <+> ppr c <> pprOptSemi st <+> text "then" <+> ppr t <> pprOptSemi se <+> text "else" <+> ppr e - - PsErrSemiColonsInCondCmd c st t se e - -> text "Unexpected semi-colons in conditional:" - $$ nest 4 expr - $$ text "Perhaps you meant to use DoAndIfThenElse?" + PsErrSemiColonsInCondCmd c st t se e + -> mkSimpleDecorated $ + text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use DoAndIfThenElse?" where pprOptSemi True = semi pprOptSemi False = empty expr = text "if" <+> ppr c <> pprOptSemi st <+> text "then" <+> ppr t <> pprOptSemi se <+> text "else" <+> ppr e - - - PsErrAtInPatPos - -> text "Found a binding for the" - <+> quotes (text "@") - <+> text "operator in a pattern position." - $$ perhapsAsPat - - PsErrLambdaCmdInFunAppCmd a - -> pp_unexpected_fun_app (text "lambda command") a - - PsErrCaseCmdInFunAppCmd a - -> pp_unexpected_fun_app (text "case command") a - - PsErrIfCmdInFunAppCmd a - -> pp_unexpected_fun_app (text "if command") a - - PsErrLetCmdInFunAppCmd a - -> pp_unexpected_fun_app (text "let command") a - - PsErrDoCmdInFunAppCmd a - -> pp_unexpected_fun_app (text "do command") a - - PsErrDoInFunAppExpr m a - -> pp_unexpected_fun_app (prependQualified m (text "do block")) a - - PsErrMDoInFunAppExpr m a - -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a - - PsErrLambdaInFunAppExpr a - -> pp_unexpected_fun_app (text "lambda expression") a - - PsErrCaseInFunAppExpr a - -> pp_unexpected_fun_app (text "case expression") a - - PsErrLambdaCaseInFunAppExpr a - -> pp_unexpected_fun_app (text "lambda-case expression") a - - PsErrLetInFunAppExpr a - -> pp_unexpected_fun_app (text "let expression") a - - PsErrIfInFunAppExpr a - -> pp_unexpected_fun_app (text "if expression") a - - PsErrProcInFunAppExpr a - -> pp_unexpected_fun_app (text "proc expression") a - - PsErrMalformedTyOrClDecl ty - -> text "Malformed head of type or class declaration:" - <+> ppr ty - - PsErrIllegalWhereInDataDecl - -> vcat - [ text "Illegal keyword 'where' in data declaration" - , text "Perhaps you intended to use GADTs or a similar language" - , text "extension to enable syntax: data T where" - ] - - PsErrIllegalTraditionalRecordSyntax s - -> text "Illegal record syntax (use TraditionalRecordSyntax):" - <+> s - - PsErrParseErrorOnInput occ - -> text "parse error on input" <+> ftext (occNameFS occ) - - PsErrIllegalDataTypeContext c - -> text "Illegal datatype context (use DatatypeContexts):" - <+> pprLHsContext (Just c) - - PsErrMalformedDecl what for - -> text "Malformed" <+> what - <+> text "declaration for" <+> quotes (ppr for) - - PsErrUnexpectedTypeAppInDecl ki what for - -> vcat [ text "Unexpected type application" - <+> text "@" <> ppr ki - , text "In the" <+> what - <+> text "declaration for" - <+> quotes (ppr for) - ] - - PsErrNotADataCon name - -> text "Not a data constructor:" <+> quotes (ppr name) - - PsErrRecordSyntaxInPatSynDecl pat - -> text "record syntax not supported for pattern synonym declarations:" - $$ ppr pat - - PsErrEmptyWhereInPatSynDecl patsyn_name - -> text "pattern synonym 'where' clause cannot be empty" - $$ text "In the pattern synonym declaration for: " - <+> ppr (patsyn_name) - - PsErrInvalidWhereBindInPatSynDecl patsyn_name decl - -> text "pattern synonym 'where' clause must bind the pattern synonym's name" - <+> quotes (ppr patsyn_name) $$ ppr decl - - PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl - -> text "pattern synonym 'where' clause must contain a single binding:" - $$ ppr decl - - PsErrDeclSpliceNotAtTopLevel d - -> hang (text "Declaration splices are allowed only" - <+> text "at the top level:") - 2 (ppr d) - - PsErrInferredTypeVarNotAllowed - -> text "Inferred type variables are not allowed here" - - PsErrIllegalRoleName role nearby - -> text "Illegal role name" <+> quotes (ppr role) - $$ case nearby of - [] -> empty - [r] -> text "Perhaps you meant" <+> quotes (ppr r) - -- will this last case ever happen?? - _ -> hang (text "Perhaps you meant one of these:") - 2 (pprWithCommas (quotes . ppr) nearby) - - PsErrMultipleNamesInStandaloneKindSignature vs - -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") - 2 (pprWithCommas ppr vs) - , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." - ] - - PsErrIllegalImportBundleForm - -> text "Illegal import form, this syntax can only be used to bundle" - $+$ text "pattern synonyms with types in module exports." - - PsErrInvalidTypeSignature lhs - -> text "Invalid type signature:" - <+> ppr lhs - <+> text ":: ..." - $$ text hint + PsErrAtInPatPos + -> mkSimpleDecorated $ + text "Found a binding for the" + <+> quotes (text "@") + <+> text "operator in a pattern position." + $$ perhapsAsPat + PsErrParseErrorOnInput occ + -> mkSimpleDecorated $ text "parse error on input" <+> ftext (occNameFS occ) + PsErrMalformedDecl what for + -> mkSimpleDecorated $ + text "Malformed" <+> what + <+> text "declaration for" <+> quotes (ppr for) + PsErrUnexpectedTypeAppInDecl ki what for + -> mkSimpleDecorated $ + vcat [ text "Unexpected type application" + <+> text "@" <> ppr ki + , text "In the" <+> what + <+> text "declaration for" + <+> quotes (ppr for) + ] + PsErrNotADataCon name + -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name) + PsErrInferredTypeVarNotAllowed + -> mkSimpleDecorated $ text "Inferred type variables are not allowed here" + PsErrIllegalTraditionalRecordSyntax s + -> mkSimpleDecorated $ + text "Illegal record syntax (use TraditionalRecordSyntax):" <+> s + PsErrParseErrorInCmd s + -> mkSimpleDecorated $ hang (text "Parse error in command:") 2 s + PsErrInPat s details + -> let msg = parse_error_in_pat + body = case details of + PEIP_NegApp -> text "-" <> ppr s + PEIP_TypeArgs peipd_tyargs + | not (null peipd_tyargs) -> ppr s <+> vcat [ + hsep [text "@" <> ppr t | t <- peipd_tyargs] + , text "Type applications in patterns are only allowed on data constructors." + ] + | otherwise -> ppr s + PEIP_OtherPatDetails (ParseContext (Just fun) _) + -> ppr s <+> text "In a function binding for the" + <+> quotes (ppr fun) + <+> text "operator." + $$ if opIsAt fun + then perhapsAsPat + else empty + _ -> ppr s + in mkSimpleDecorated $ msg <+> body + PsErrParseRightOpSectionInPat infixOcc s + -> mkSimpleDecorated $ parse_error_in_pat <+> pprInfixOcc infixOcc <> ppr s + PsErrIllegalRoleName role nearby + -> mkSimpleDecorated $ + text "Illegal role name" <+> quotes (ppr role) + $$ case nearby of + [] -> empty + [r] -> text "Perhaps you meant" <+> quotes (ppr r) + -- will this last case ever happen?? + _ -> hang (text "Perhaps you meant one of these:") + 2 (pprWithCommas (quotes . ppr) nearby) + PsErrInvalidTypeSignature lhs + -> mkSimpleDecorated $ + text "Invalid type signature:" + <+> ppr lhs + <+> text ":: ..." + $$ text hint where hint | foreign_RDR `looks_like` lhs = "Perhaps you meant to use ForeignFunctionInterface?" @@ -537,7 +488,7 @@ pp_err = \case -- so check for that, and suggest. cf #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword - -- looks_like :: RdrName -> LHsExpr GhcPs -> Bool -- AZ + -- looks_like :: RdrName -> LHsExpr GhcPsErr -> Bool -- AZ looks_like s (L _ (HsVar _ (L _ v))) = v == s looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False @@ -545,83 +496,276 @@ pp_err = \case foreign_RDR = mkUnqual varName (fsLit "foreign") default_RDR = mkUnqual varName (fsLit "default") pattern_RDR = mkUnqual varName (fsLit "pattern") - - PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where - -> vcat [ text "Unexpected type" <+> quotes (ppr t) - , text "In the" <+> what - <+> text "declaration for" <+> quotes tc' - , vcat[ (text "A" <+> what - <+> text "declaration should have form") - , nest 2 - (what - <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ] - where - -- Avoid printing a constraint tuple in the error message. Print - -- a plain old tuple instead (since that's what the user probably - -- wrote). See #14907 - tc' = ppr $ filterCTuple tc - - PsErrCmmParser cmm_err -> case cmm_err of - CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name - CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun - CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv - CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety - CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint - - PsErrExpectedHyphen - -> text "Expected a hyphen" - - PsErrSpaceInSCC - -> text "Spaces are not allowed in SCCs" - - PsErrEmptyDoubleQuotes th_on - -> if th_on then vcat (msg ++ th_msg) else vcat msg - where - msg = [ text "Parser error on `''`" - , text "Character literals may not be empty" - ] - th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell," - , text "but the type variable or constructor is missing" - ] - - PsErrInvalidPackageName pkg - -> vcat + PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where + -> mkSimpleDecorated $ + vcat [ text "Unexpected type" <+> quotes (ppr t) + , text "In the" <+> what + <+> text "declaration for" <+> quotes tc' + , vcat[ (text "A" <+> what + <+> text "declaration should have form") + , nest 2 + (what + <+> tc' + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ] + where + -- Avoid printing a constraint tuple in the error message. Print + -- a plain old tuple instead (since that's what the user probably + -- wrote). See #14907 + tc' = ppr $ filterCTuple tc + PsErrInvalidPackageName pkg + -> mkSimpleDecorated $ vcat [ text "Parse error" <> colon <+> quotes (ftext pkg) , text "Version number or non-alphanumeric" <+> text "character in package name" ] - PsErrInvalidRuleActivationMarker - -> text "Invalid rule activation marker" - - PsErrLinearFunction - -> text "Enable LinearTypes to allow linear functions" - - PsErrMultiWayIf - -> text "Multi-way if-expressions need MultiWayIf turned on" - - PsErrExplicitForall is_unicode - -> vcat - [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type" - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax:" <+> - forallSym is_unicode <+> text "<tvs>. <type>" - ] - where - forallSym True = text "∀" - forallSym False = text "forall" - - PsErrIllegalQualifiedDo qdoDoc - -> vcat - [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block" - , text "Perhaps you intended to use QualifiedDo" - ] + diagnosticReason = \case + PsUnknownMessage m -> diagnosticReason m + PsWarnTab{} -> WarningWithFlag Opt_WarnTabs + PsWarnTransitionalLayout{} -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional + PsWarnOperatorWhitespaceExtConflict{} -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict + PsWarnOperatorWhitespace{} -> WarningWithFlag Opt_WarnOperatorWhitespace + PsWarnHaddockInvalidPos -> WarningWithFlag Opt_WarnInvalidHaddock + PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock + PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder + PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType + PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas + PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule + PsErrLexer{} -> ErrorWithoutFlag + PsErrCmmLexer -> ErrorWithoutFlag + PsErrCmmParser{} -> ErrorWithoutFlag + PsErrParse{} -> ErrorWithoutFlag + PsErrTypeAppWithoutSpace{} -> ErrorWithoutFlag + PsErrLazyPatWithoutSpace{} -> ErrorWithoutFlag + PsErrBangPatWithoutSpace{} -> ErrorWithoutFlag + PsErrInvalidInfixHole -> ErrorWithoutFlag + PsErrExpectedHyphen -> ErrorWithoutFlag + PsErrSpaceInSCC -> ErrorWithoutFlag + PsErrEmptyDoubleQuotes{} -> ErrorWithoutFlag + PsErrLambdaCase{} -> ErrorWithoutFlag + PsErrEmptyLambda{} -> ErrorWithoutFlag + PsErrLinearFunction{} -> ErrorWithoutFlag + PsErrMultiWayIf{} -> ErrorWithoutFlag + PsErrOverloadedRecordUpdateNotEnabled{} -> ErrorWithoutFlag + PsErrNumUnderscores{} -> ErrorWithoutFlag + PsErrIllegalBangPattern{} -> ErrorWithoutFlag + PsErrOverloadedRecordDotInvalid{} -> ErrorWithoutFlag + PsErrIllegalPatSynExport -> ErrorWithoutFlag + PsErrOverloadedRecordUpdateNoQualifiedFields -> ErrorWithoutFlag + PsErrExplicitForall{} -> ErrorWithoutFlag + PsErrIllegalQualifiedDo{} -> ErrorWithoutFlag + PsErrQualifiedDoInCmd{} -> ErrorWithoutFlag + PsErrRecordSyntaxInPatSynDecl{} -> ErrorWithoutFlag + PsErrEmptyWhereInPatSynDecl{} -> ErrorWithoutFlag + PsErrInvalidWhereBindInPatSynDecl{} -> ErrorWithoutFlag + PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag + PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag + PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag + PsErrIllegalExplicitNamespace -> ErrorWithoutFlag + PsErrUnallowedPragma{} -> ErrorWithoutFlag + PsErrImportPostQualified -> ErrorWithoutFlag + PsErrImportQualifiedTwice -> ErrorWithoutFlag + PsErrIllegalImportBundleForm -> ErrorWithoutFlag + PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag + PsErrMissingBlock -> ErrorWithoutFlag + PsErrUnsupportedBoxedSumExpr{} -> ErrorWithoutFlag + PsErrUnsupportedBoxedSumPat{} -> ErrorWithoutFlag + PsErrUnexpectedQualifiedConstructor{} -> ErrorWithoutFlag + PsErrTupleSectionInPat{} -> ErrorWithoutFlag + PsErrOpFewArgs{} -> ErrorWithoutFlag + PsErrVarForTyCon{} -> ErrorWithoutFlag + PsErrMalformedEntityString -> ErrorWithoutFlag + PsErrDotsInRecordUpdate -> ErrorWithoutFlag + PsErrInvalidDataCon{} -> ErrorWithoutFlag + PsErrInvalidInfixDataCon{} -> ErrorWithoutFlag + PsErrUnpackDataCon -> ErrorWithoutFlag + PsErrUnexpectedKindAppInDataCon{} -> ErrorWithoutFlag + PsErrInvalidRecordCon{} -> ErrorWithoutFlag + PsErrIllegalUnboxedStringInPat{} -> ErrorWithoutFlag + PsErrDoNotationInPat{} -> ErrorWithoutFlag + PsErrIfThenElseInPat -> ErrorWithoutFlag + PsErrLambdaCaseInPat -> ErrorWithoutFlag + PsErrCaseInPat -> ErrorWithoutFlag + PsErrLetInPat -> ErrorWithoutFlag + PsErrLambdaInPat -> ErrorWithoutFlag + PsErrArrowExprInPat{} -> ErrorWithoutFlag + PsErrArrowCmdInPat{} -> ErrorWithoutFlag + PsErrArrowCmdInExpr{} -> ErrorWithoutFlag + PsErrViewPatInExpr{} -> ErrorWithoutFlag + PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrDoInFunAppExpr{} -> ErrorWithoutFlag + PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag + PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag + PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag + PsErrLambdaCaseInFunAppExpr{} -> ErrorWithoutFlag + PsErrLetInFunAppExpr{} -> ErrorWithoutFlag + PsErrIfInFunAppExpr{} -> ErrorWithoutFlag + PsErrProcInFunAppExpr{} -> ErrorWithoutFlag + PsErrMalformedTyOrClDecl{} -> ErrorWithoutFlag + PsErrIllegalWhereInDataDecl -> ErrorWithoutFlag + PsErrIllegalDataTypeContext{} -> ErrorWithoutFlag + PsErrPrimStringInvalidChar -> ErrorWithoutFlag + PsErrSuffixAT -> ErrorWithoutFlag + PsErrPrecedenceOutOfRange{} -> ErrorWithoutFlag + PsErrSemiColonsInCondExpr{} -> ErrorWithoutFlag + PsErrSemiColonsInCondCmd{} -> ErrorWithoutFlag + PsErrAtInPatPos -> ErrorWithoutFlag + PsErrParseErrorOnInput{} -> ErrorWithoutFlag + PsErrMalformedDecl{} -> ErrorWithoutFlag + PsErrUnexpectedTypeAppInDecl{} -> ErrorWithoutFlag + PsErrNotADataCon{} -> ErrorWithoutFlag + PsErrInferredTypeVarNotAllowed -> ErrorWithoutFlag + PsErrIllegalTraditionalRecordSyntax{} -> ErrorWithoutFlag + PsErrParseErrorInCmd{} -> ErrorWithoutFlag + PsErrInPat{} -> ErrorWithoutFlag + PsErrIllegalRoleName{} -> ErrorWithoutFlag + PsErrInvalidTypeSignature{} -> ErrorWithoutFlag + PsErrUnexpectedTypeInDecl{} -> ErrorWithoutFlag + PsErrInvalidPackageName{} -> ErrorWithoutFlag + PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag + + diagnosticHints = \case + PsUnknownMessage m -> diagnosticHints m + PsWarnTab{} -> [SuggestUseSpaces] + PsWarnTransitionalLayout{} -> noHints + PsWarnOperatorWhitespaceExtConflict{} -> noHints + PsWarnOperatorWhitespace{} -> noHints + PsWarnHaddockInvalidPos -> noHints + PsWarnHaddockIgnoreMulti -> noHints + PsWarnStarBinder -> noHints + PsWarnStarIsType -> noHints + PsWarnUnrecognisedPragma -> noHints + PsWarnImportPreQualified -> noHints + PsErrLexer{} -> noHints + PsErrCmmLexer -> noHints + PsErrCmmParser{} -> noHints + PsErrParse token PsErrParseDetails{..} -> case token of + "" -> [] + "$" | not ped_th_enabled -> [SuggestExtension LangExt.TemplateHaskell] -- #7396 + "<-" | ped_mdo_in_last_100 -> [SuggestExtension LangExt.RecursiveDo] + | otherwise -> [SuggestMissingDo] + "=" | ped_do_in_last_100 -> [SuggestLetInDo] -- #15849 + _ | not ped_pat_syn_enabled + , ped_pattern_parsed -> [SuggestExtension LangExt.PatternSynonyms] -- #12429 + | otherwise -> [] + PsErrTypeAppWithoutSpace{} -> noHints + PsErrLazyPatWithoutSpace{} -> noHints + PsErrBangPatWithoutSpace{} -> noHints + PsErrInvalidInfixHole -> noHints + PsErrExpectedHyphen -> noHints + PsErrSpaceInSCC -> noHints + PsErrEmptyDoubleQuotes{} -> noHints + PsErrLambdaCase{} -> noHints + PsErrEmptyLambda{} -> noHints + PsErrLinearFunction{} -> noHints + PsErrMultiWayIf{} -> noHints + PsErrOverloadedRecordUpdateNotEnabled{} -> noHints + PsErrNumUnderscores{} -> noHints + PsErrIllegalBangPattern{} -> noHints + PsErrOverloadedRecordDotInvalid{} -> noHints + PsErrIllegalPatSynExport -> noHints + PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints + PsErrExplicitForall{} -> noHints + PsErrIllegalQualifiedDo{} -> noHints + PsErrQualifiedDoInCmd{} -> noHints + PsErrRecordSyntaxInPatSynDecl{} -> noHints + PsErrEmptyWhereInPatSynDecl{} -> noHints + PsErrInvalidWhereBindInPatSynDecl{} -> noHints + PsErrNoSingleWhereBindInPatSynDecl{} -> noHints + PsErrDeclSpliceNotAtTopLevel{} -> noHints + PsErrMultipleNamesInStandaloneKindSignature{} -> noHints + PsErrIllegalExplicitNamespace -> noHints + PsErrUnallowedPragma{} -> noHints + PsErrImportPostQualified -> noHints + PsErrImportQualifiedTwice -> noHints + PsErrIllegalImportBundleForm -> noHints + PsErrInvalidRuleActivationMarker -> noHints + PsErrMissingBlock -> noHints + PsErrUnsupportedBoxedSumExpr{} -> noHints + PsErrUnsupportedBoxedSumPat{} -> noHints + PsErrUnexpectedQualifiedConstructor{} -> noHints + PsErrTupleSectionInPat{} -> noHints + PsErrOpFewArgs{} -> noHints + PsErrVarForTyCon{} -> noHints + PsErrMalformedEntityString -> noHints + PsErrDotsInRecordUpdate -> noHints + PsErrInvalidDataCon{} -> noHints + PsErrInvalidInfixDataCon{} -> noHints + PsErrUnpackDataCon -> noHints + PsErrUnexpectedKindAppInDataCon{} -> noHints + PsErrInvalidRecordCon{} -> noHints + PsErrIllegalUnboxedStringInPat{} -> noHints + PsErrDoNotationInPat{} -> noHints + PsErrIfThenElseInPat -> noHints + PsErrLambdaCaseInPat -> noHints + PsErrCaseInPat -> noHints + PsErrLetInPat -> noHints + PsErrLambdaInPat -> noHints + PsErrArrowExprInPat{} -> noHints + PsErrArrowCmdInPat{} -> noHints + PsErrArrowCmdInExpr{} -> noHints + PsErrViewPatInExpr{} -> noHints + PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrDoInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrMDoInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrLambdaInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrCaseInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrLambdaCaseInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrLetInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrMalformedTyOrClDecl{} -> noHints + PsErrIllegalWhereInDataDecl -> noHints + PsErrIllegalDataTypeContext{} -> noHints + PsErrPrimStringInvalidChar -> noHints + PsErrSuffixAT -> noHints + PsErrPrecedenceOutOfRange{} -> noHints + PsErrSemiColonsInCondExpr{} -> noHints + PsErrSemiColonsInCondCmd{} -> noHints + PsErrAtInPatPos -> noHints + PsErrParseErrorOnInput{} -> noHints + PsErrMalformedDecl{} -> noHints + PsErrUnexpectedTypeAppInDecl{} -> noHints + PsErrNotADataCon{} -> noHints + PsErrInferredTypeVarNotAllowed -> noHints + PsErrIllegalTraditionalRecordSyntax{} -> noHints + PsErrParseErrorInCmd{} -> noHints + PsErrInPat _ details -> case details of + PEIP_RecPattern args YesPatIsRecursive ctx + | length args /= 0 -> catMaybes [sug_recdo, sug_missingdo ctx] + | otherwise -> catMaybes [sug_missingdo ctx] + PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx] + _ -> [] + where + sug_recdo = Just (SuggestExtension LangExt.RecursiveDo) + sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo + sug_missingdo _ = Nothing + PsErrParseRightOpSectionInPat{} -> noHints + PsErrIllegalRoleName{} -> noHints + PsErrInvalidTypeSignature{} -> noHints + PsErrUnexpectedTypeInDecl{} -> noHints + PsErrInvalidPackageName{} -> noHints + +suggestParensAndBlockArgs :: [GhcHint] +suggestParensAndBlockArgs = + [SuggestParentheses, SuggestExtension LangExt.BlockArguments] pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc pp_unexpected_fun_app e a = text "Unexpected " <> e <> text " in function application:" $$ nest 4 (ppr a) - $$ text "You could write it with parentheses" - $$ text "Or perhaps you meant to enable BlockArguments?" + +parse_error_in_pat :: SDoc +parse_error_in_pat = text "Parse error in pattern:" + +perhapsAsPat :: SDoc +perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 293dcc3ee0..d75c223253 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -1,9 +1,502 @@ +{-# LANGUAGE ExistentialQuantification #-} module GHC.Parser.Errors.Types where +import GHC.Prelude + +import Data.Typeable + +import GHC.Core.TyCon (Role) +import GHC.Data.FastString +import GHC.Hs +import GHC.Parser.Types import GHC.Types.Error +import GHC.Types.Name.Occurrence (OccName) +import GHC.Types.Name.Reader +import GHC.Unit.Module.Name +import GHC.Utils.Outputable + +-- The type aliases below are useful to make some type signatures a bit more +-- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. + +type PsWarning = PsMessage -- /INVARIANT/: The diagnosticReason is a Warning reason +type PsError = PsMessage -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag data PsMessage - = PsUnknownMessage !DiagnosticMessage - -- ^ Simply rewraps a generic 'DiagnosticMessage'. More - -- constructors will be added in the future (#18516). + = + {-| An \"unknown\" message from the parser. This type constructor allows + arbitrary messages to be embedded. The typical use case would be GHC plugins + willing to emit custom diagnostics. + -} + forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a + + {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs + when tabulations (tabs) are found within a file. + + Test case(s): parser/should_fail/T12610 + parser/should_compile/T9723b + parser/should_compile/T9723a + parser/should_compile/read043 + parser/should_fail/T16270 + warnings/should_compile/T9230 + + -} + | PsWarnTab !Word -- ^ Number of other occurrences other than the first one + + {-| PsWarnTransitionalLayout is a warning (controlled by the + -Walternative-layout-rule-transitional flag) that occurs when pipes ('|') + or 'where' are at the same depth of an implicit layout block. + + Example(s): + + f :: IO () + f + | True = do + let x = () + y = () + return () + | True = return () + + Test case(s): layout/layout006 + layout/layout003 + layout/layout001 + + -} + | PsWarnTransitionalLayout !TransLayoutReason + + -- | Unrecognised pragma + | PsWarnUnrecognisedPragma + + -- | Invalid Haddock comment position + | PsWarnHaddockInvalidPos + + -- | Multiple Haddock comment for the same entity + | PsWarnHaddockIgnoreMulti + + -- | Found binding occurrence of "*" while StarIsType is enabled + | PsWarnStarBinder + + -- | Using "*" for "Type" without StarIsType enabled + | PsWarnStarIsType + + -- | Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled + | PsWarnImportPreQualified + + | PsWarnOperatorWhitespaceExtConflict !OperatorWhitespaceSymbol + + | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence + + -- | LambdaCase syntax used without the extension enabled + | PsErrLambdaCase + + -- | A lambda requires at least one parameter + | PsErrEmptyLambda + + -- | Underscores in literals without the extension enabled + | PsErrNumUnderscores !NumUnderscoreReason + + -- | Invalid character in primitive string + | PsErrPrimStringInvalidChar + + -- | Missing block + | PsErrMissingBlock + + -- | Lexer error + | PsErrLexer !LexErr !LexErrKind + + -- | Suffix occurrence of `@` + | PsErrSuffixAT + + -- | Parse errors + | PsErrParse !String !PsErrParseDetails + + -- | Cmm lexer error + | PsErrCmmLexer + + -- | Unsupported boxed sum in expression + | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs)) + + -- | Unsupported boxed sum in pattern + | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs)) + + -- | Unexpected qualified constructor + | PsErrUnexpectedQualifiedConstructor !RdrName + + -- | Tuple section in pattern context + | PsErrTupleSectionInPat + + -- | Bang-pattern without BangPattterns enabled + | PsErrIllegalBangPattern !(Pat GhcPs) + + -- | Operator applied to too few arguments + | PsErrOpFewArgs !StarIsType !RdrName + + -- | Import: multiple occurrences of 'qualified' + | PsErrImportQualifiedTwice + + -- | Post qualified import without 'ImportQualifiedPost' + | PsErrImportPostQualified + + -- | Explicit namespace keyword without 'ExplicitNamespaces' + | PsErrIllegalExplicitNamespace + + -- | Expecting a type constructor but found a variable + | PsErrVarForTyCon !RdrName + + -- | Illegal export form allowed by PatternSynonyms + | PsErrIllegalPatSynExport + + -- | Malformed entity string + | PsErrMalformedEntityString + + -- | Dots used in record update + | PsErrDotsInRecordUpdate + + -- | Precedence out of range + | PsErrPrecedenceOutOfRange !Int + + -- | Invalid use of record dot syntax `.' + | PsErrOverloadedRecordDotInvalid + + -- | `OverloadedRecordUpdate` is not enabled. + | PsErrOverloadedRecordUpdateNotEnabled + + -- | Can't use qualified fields when OverloadedRecordUpdate is enabled. + | PsErrOverloadedRecordUpdateNoQualifiedFields + + -- | Cannot parse data constructor in a data/newtype declaration + | PsErrInvalidDataCon !(HsType GhcPs) + + -- | Cannot parse data constructor in a data/newtype declaration + | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs) + + -- | UNPACK applied to a data constructor + | PsErrUnpackDataCon + + -- | Unexpected kind application in data/newtype declaration + | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs) + + -- | Not a record constructor + | PsErrInvalidRecordCon !(PatBuilder GhcPs) + + -- | Illegal unboxed string literal in pattern + | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs) + + -- | Do-notation in pattern + | PsErrDoNotationInPat + + -- | If-then-else syntax in pattern + | PsErrIfThenElseInPat + + -- | Lambda-case in pattern + | PsErrLambdaCaseInPat + + -- | case..of in pattern + | PsErrCaseInPat + + -- | let-syntax in pattern + | PsErrLetInPat + + -- | Lambda-syntax in pattern + | PsErrLambdaInPat + + -- | Arrow expression-syntax in pattern + | PsErrArrowExprInPat !(HsExpr GhcPs) + + -- | Arrow command-syntax in pattern + | PsErrArrowCmdInPat !(HsCmd GhcPs) + + -- | Arrow command-syntax in expression + | PsErrArrowCmdInExpr !(HsCmd GhcPs) + + -- | View-pattern in expression + | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs) + + -- | Type-application without space before '@' + | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) + + -- | Lazy-pattern ('~') without space after it + | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs) + + -- | Bang-pattern ('!') without space after it + | PsErrBangPatWithoutSpace !(LHsExpr GhcPs) + + -- | Pragma not allowed in this position + | PsErrUnallowedPragma !(HsPragE GhcPs) + + -- | Qualified do block in command + | PsErrQualifiedDoInCmd !ModuleName + + -- | Invalid infix hole, expected an infix operator + | PsErrInvalidInfixHole + + -- | Unexpected semi-colons in conditional expression + | PsErrSemiColonsInCondExpr + !(HsExpr GhcPs) -- ^ conditional expr + !Bool -- ^ "then" semi-colon? + !(HsExpr GhcPs) -- ^ "then" expr + !Bool -- ^ "else" semi-colon? + !(HsExpr GhcPs) -- ^ "else" expr + + -- | Unexpected semi-colons in conditional command + | PsErrSemiColonsInCondCmd + !(HsExpr GhcPs) -- ^ conditional expr + !Bool -- ^ "then" semi-colon? + !(HsCmd GhcPs) -- ^ "then" expr + !Bool -- ^ "else" semi-colon? + !(HsCmd GhcPs) -- ^ "else" expr + + -- | @-operator in a pattern position + | PsErrAtInPatPos + + -- | Unexpected lambda command in function application + | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected case command in function application + | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected if command in function application + | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected let command in function application + | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected do command in function application + | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected do block in function application + | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + + -- | Unexpected mdo block in function application + | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + + -- | Unexpected lambda expression in function application + | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected case expression in function application + | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected lambda-case expression in function application + | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected let expression in function application + | PsErrLetInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected if expression in function application + | PsErrIfInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected proc expression in function application + | PsErrProcInFunAppExpr !(LHsExpr GhcPs) + + -- | Malformed head of type or class declaration + | PsErrMalformedTyOrClDecl !(LHsType GhcPs) + + -- | Illegal 'where' keyword in data declaration + | PsErrIllegalWhereInDataDecl + + -- | Illegal datatype context + | PsErrIllegalDataTypeContext !(LHsContext GhcPs) + + -- | Parse error on input + | PsErrParseErrorOnInput !OccName + + -- | Malformed ... declaration for ... + | PsErrMalformedDecl !SDoc !RdrName + + -- | Unexpected type application in a declaration + | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName + + -- | Not a data constructor + | PsErrNotADataCon !RdrName + + -- | Record syntax used in pattern synonym declaration + | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs) + + -- | Empty 'where' clause in pattern-synonym declaration + | PsErrEmptyWhereInPatSynDecl !RdrName + + -- | Invalid binding name in 'where' clause of pattern-synonym declaration + | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + + -- | Multiple bindings in 'where' clause of pattern-synonym declaration + | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + + -- | Declaration splice not a top-level + | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs) + + -- | Inferred type variables not allowed here + | PsErrInferredTypeVarNotAllowed + + -- | Multiple names in standalone kind signatures + | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs] + + -- | Illegal import bundle form + | PsErrIllegalImportBundleForm + + -- | Illegal role name + | PsErrIllegalRoleName !FastString [Role] + + -- | Invalid type signature + | PsErrInvalidTypeSignature !(LHsExpr GhcPs) + + -- | Unexpected type in declaration + | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) + !SDoc + !RdrName + [LHsTypeArg GhcPs] + !SDoc + + -- | Expected a hyphen + | PsErrExpectedHyphen + + -- | Found a space in a SCC + | PsErrSpaceInSCC + + -- | Found two single quotes + | PsErrEmptyDoubleQuotes !Bool + -- ^ Is TH on? + + -- | Invalid package name + | PsErrInvalidPackageName !FastString + + -- | Invalid rule activation marker + | PsErrInvalidRuleActivationMarker + + -- | Linear function found but LinearTypes not enabled + | PsErrLinearFunction + + -- | Multi-way if-expression found but MultiWayIf not enabled + | PsErrMultiWayIf + + -- | Explicit forall found but no extension allowing it is enabled + | PsErrExplicitForall !Bool + -- ^ is Unicode forall? + + -- | Found qualified-do without QualifiedDo enabled + | PsErrIllegalQualifiedDo !SDoc + + -- | Cmm parser error + | PsErrCmmParser !CmmParserError + + -- | Illegal traditional record syntax + -- + -- TODO: distinguish errors without using SDoc + | PsErrIllegalTraditionalRecordSyntax !SDoc + + -- | Parse error in command + -- + -- TODO: distinguish errors without using SDoc + | PsErrParseErrorInCmd !SDoc + + -- | Parse error in pattern + | PsErrInPat !(PatBuilder GhcPs) !PsErrInPatDetails + + -- | Parse error in right operator section pattern + -- TODO: embed the proper operator, if possible + | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs) + +newtype StarIsType = StarIsType Bool + +-- | Extra details about a parse error, which helps +-- us in determining which should be the hints to +-- suggest. +data PsErrParseDetails + = PsErrParseDetails + { ped_th_enabled :: !Bool + -- Is 'TemplateHaskell' enabled? + , ped_do_in_last_100 :: !Bool + -- ^ Is there a 'do' in the last 100 characters? + , ped_mdo_in_last_100 :: !Bool + -- ^ Is there an 'mdo' in the last 100 characters? + , ped_pat_syn_enabled :: !Bool + -- ^ Is 'PatternSynonyms' enabled? + , ped_pattern_parsed :: !Bool + -- ^ Did we parse a \"pattern\" keyword? + } + +-- | Is the parsed pattern recursive? +data PatIsRecursive + = YesPatIsRecursive + | NoPatIsRecursive + +data PatIncompleteDoBlock + = YesIncompleteDoBlock + | NoIncompleteDoBlock + deriving Eq + +-- | Extra information for the expression GHC is currently inspecting/parsing. +-- It can be used to generate more informative parser diagnostics and hints. +data ParseContext + = ParseContext + { is_infix :: !(Maybe RdrName) + -- ^ If 'Just', this is an infix + -- pattern with the binded operator name + , incomplete_do_block :: !PatIncompleteDoBlock + -- ^ Did the parser likely fail due to an incomplete do block? + } deriving Eq + +data PsErrInPatDetails + = PEIP_NegApp + -- ^ Negative application pattern? + | PEIP_TypeArgs [HsPatSigType GhcPs] + -- ^ The list of type arguments for the pattern + | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments + !PatIsRecursive -- ^ Is the parsed pattern recursive? + !ParseContext + | PEIP_OtherPatDetails !ParseContext + +noParseContext :: ParseContext +noParseContext = ParseContext Nothing NoIncompleteDoBlock + +incompleteDoBlock :: ParseContext +incompleteDoBlock = ParseContext Nothing YesIncompleteDoBlock + +-- | Builds a 'PsErrInPatDetails' with the information provided by the 'ParseContext'. +fromParseContext :: ParseContext -> PsErrInPatDetails +fromParseContext = PEIP_OtherPatDetails + +data NumUnderscoreReason + = NumUnderscore_Integral + | NumUnderscore_Float + deriving (Show,Eq,Ord) + +data LexErrKind + = LexErrKind_EOF -- ^ End of input + | LexErrKind_UTF8 -- ^ UTF-8 decoding error + | LexErrKind_Char !Char -- ^ Error at given character + deriving (Show,Eq,Ord) + +data LexErr + = LexError -- ^ Lexical error + | LexUnknownPragma -- ^ Unknown pragma + | LexErrorInPragma -- ^ Lexical error in pragma + | LexNumEscapeRange -- ^ Numeric escape sequence out of range + | LexStringCharLit -- ^ Lexical error in string/character literal + | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal + | LexUnterminatedComment -- ^ Unterminated `{-' + | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma + | LexUnterminatedQQ -- ^ Unterminated quasiquotation + +-- | Errors from the Cmm parser +data CmmParserError + = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive + | CmmUnknownMacro !FastString -- ^ Unknown macro + | CmmUnknownCConv !String -- ^ Unknown calling convention + | CmmUnrecognisedSafety !String -- ^ Unrecognised safety + | CmmUnrecognisedHint !String -- ^ Unrecognised hint + +-- | The operator symbol in the 'PsOperatorWhitespaceExtConflictMessage' diagnostic. +data OperatorWhitespaceSymbol + = OperatorWhitespaceSymbol_PrefixPercent + | OperatorWhitespaceSymbol_PrefixDollar + | OperatorWhitespaceSymbol_PrefixDollarDollar + +-- | The operator occurrence type in the 'PsOperatorWhitespaceMessage' diagnostic. +data OperatorWhitespaceOccurrence + = OperatorWhitespaceOccurrence_Prefix + | OperatorWhitespaceOccurrence_Suffix + | OperatorWhitespaceOccurrence_TightInfix + +data TransLayoutReason + = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block" + | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block") diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 52a98d86dc..daa8bc78a5 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -30,8 +30,6 @@ import GHC.Driver.Config import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr -import GHC.Parser.Errors import GHC.Parser ( parseHeader ) import GHC.Parser.Lexer @@ -53,7 +51,6 @@ import GHC.Utils.Exception as Exception import GHC.Data.StringBuffer import GHC.Data.Maybe -import GHC.Data.Bag (Bag, isEmptyBag ) import GHC.Data.FastString import qualified GHC.Data.Strict as Strict @@ -79,7 +76,7 @@ getImports :: ParserOpts -- ^ Parser options -> FilePath -- ^ The original source filename (used for locations -- in the function result) -> IO (Either - (Bag PsError) + (Messages PsMessage) ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName)) @@ -95,8 +92,8 @@ getImports popts implicit_prelude buf filename source_filename = do let (_warns, errs) = getMessages pst -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500. - if not (isEmptyBag errs) - then throwErrors $ foldPsMessages mkParserErr errs + if not (isEmptyMessages errs) + then throwErrors (GhcPsMessage <$> errs) else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index f9494afa6a..10c9f2042f 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -75,6 +75,7 @@ module GHC.Parser.Lexer ( commentToAnnotation, HdkComment(..), warnopt, + addPsMessage ) where import GHC.Prelude @@ -101,17 +102,17 @@ import Data.Map (Map) import qualified Data.Map as Map -- compiler -import GHC.Data.Bag +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.StringBuffer import GHC.Data.FastString +import GHC.Types.Error hiding ( getErrorMessages, getMessages ) import GHC.Types.Unique.FM import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) -import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) @@ -121,7 +122,8 @@ import GHC.Parser.CharClass import GHC.Parser.Annotation import GHC.Driver.Flags -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () } -- ----------------------------------------------------------------------------- @@ -362,7 +364,7 @@ $tab { warnTab } } <0,option_prags> { - "{-#" { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma + "{-#" { warnThen PsWarnUnrecognisedPragma (nested_comment lexToken) } } @@ -1143,7 +1145,8 @@ hopefully_open_brace span buf len Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len - else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span) + else addFatalError $ + mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -1528,7 +1531,10 @@ docCommentEnd input commentAcc docType buf span = do commentEnd lexToken input commentAcc finalizeComment buf span errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) []) +errBrace (AI end _) span = + failLocMsgP (realSrcSpanStart span) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) open_brace, close_brace :: Action open_brace span _str _len = do @@ -1587,7 +1593,7 @@ varid span buf len = lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState - addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState)) + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase return ITlcase _ -> return ITcase maybe_layout keyword @@ -1619,8 +1625,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False varsym_prefix :: Action varsym_prefix = sym $ \span exts s -> let warnExtConflict errtok = - do { addWarning Opt_WarnOperatorWhitespaceExtConflict $ - PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok + do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) ; return (ITvarsym s) } in if | s == fsLit "@" -> @@ -1646,19 +1651,19 @@ varsym_prefix = sym $ \span exts s -> | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_Prefix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action varsym_suffix = sym $ \span _ s -> - if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT []) + if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_Suffix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] @@ -1668,9 +1673,9 @@ varsym_tight_infix = sym $ \span exts s -> | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) | s == fsLit "." -> return ITdot | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_TightInfix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix)) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] @@ -1726,7 +1731,8 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrNumUnderscores NumUnderscore_Integral + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int @@ -1767,7 +1773,8 @@ tok_frac drop f span buf len = do let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrNumUnderscores NumUnderscore_Float + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token @@ -1946,7 +1953,9 @@ lex_string_prag_comment mkTok span _buf _len = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) []) + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) -- ----------------------------------------------------------------------------- -- Strings & Chars @@ -1983,7 +1992,8 @@ lex_string s = do setInput i when (any (> '\xFF') s') $ do pState <- getPState - let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrPrimStringInvalidChar + let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg addError err return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> @@ -2246,7 +2256,7 @@ quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput reportLexError start (psRealLoc end) buf - (\k -> PsError (PsErrLexer LexUnterminatedQQ k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) -- ----------------------------------------------------------------------------- -- Warnings @@ -2256,9 +2266,9 @@ warnTab srcspan _buf _len = do addTabWarning (psRealSpan srcspan) lexToken -warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action -warnThen flag warning action srcspan buf len = do - addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Strict.Nothing)) +warnThen :: PsMessage -> Action -> Action +warnThen warning action srcspan buf len = do + addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -2310,6 +2320,10 @@ warnopt f options = f `EnumSet.member` pWarningFlags options data ParserOpts = ParserOpts { pWarningFlags :: EnumSet WarningFlag -- ^ enabled warning flags , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + , pMakePsMessage :: SrcSpan -> PsMessage -> MsgEnvelope PsMessage + -- ^ The function to be used to construct diagnostic messages. + -- The idea is to partially-apply 'mkParserMessage' upstream, to + -- avoid the dependency on the 'DynFlags' in the Lexer. } -- | Haddock comment as produced by the lexer. These are accumulated in @@ -2324,10 +2338,9 @@ data HdkComment data PState = PState { buffer :: StringBuffer, options :: ParserOpts, - warnings :: Bag PsWarning, - errors :: Bag PsError, - tab_first :: Strict.Maybe RealSrcSpan, - -- pos of first tab warning in the file + warnings :: Messages PsMessage, + errors :: Messages PsMessage, + tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Word, -- number of tab warnings in the file last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token prev_loc :: PsSpan, -- pos of previous token, including comments, @@ -2414,12 +2427,12 @@ thenP :: P a -> (a -> P b) -> P b POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> PsError) -> P a +failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a failMsgP f = do pState <- getPState addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a failLocMsgP loc1 loc2 f = addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) @@ -2757,6 +2770,7 @@ data ExtBits mkParserOpts :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens @@ -2768,11 +2782,12 @@ mkParserOpts -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts' -mkParserOpts warningFlags extensionFlags +mkParserOpts warningFlags extensionFlags mkMessage safeImports isHaddock rawTokStream usePosPrags = ParserOpts { - pWarningFlags = warningFlags - , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + pWarningFlags = warningFlags + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + , pMakePsMessage = mkMessage } where safeHaskellBit = SafeHaskellBit `setBitIf` safeImports @@ -2845,8 +2860,8 @@ initParserState options buf loc = PState { buffer = buf, options = options, - errors = emptyBag, - warnings = emptyBag, + errors = emptyMessages, + warnings = emptyMessages, tab_first = Strict.Nothing, tab_count = 0, last_tk = Strict.Nothing, @@ -2893,15 +2908,15 @@ class Monad m => MonadP m where -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. -- - addError :: PsError -> m () + addError :: MsgEnvelope PsMessage -> m () -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings. - addWarning :: WarningFlag -> PsWarning -> m () + addWarning :: MsgEnvelope PsMessage -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state. - addFatalError :: PsError -> m a + addFatalError :: MsgEnvelope PsMessage -> m a -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool @@ -2917,12 +2932,13 @@ class Monad m => MonadP m where instance MonadP P where addError err - = P $ \s -> POk s { errors = err `consBag` errors s} () + = P $ \s -> POk s { errors = err `addMessage` errors s} () - addWarning option w - = P $ \s -> if warnopt option (options s) - then POk (s { warnings = w `consBag` warnings s }) () - else POk s () + -- If the warning is meant to be suppressed, GHC will assign + -- a `SevIgnore` severity and the message will be discarded, + -- so we can simply add it no matter what. + addWarning w + = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () addFatalError err = addError err >> P PFailed @@ -2964,6 +2980,11 @@ getFinalCommentsFor _ = return emptyComments getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos +addPsMessage :: SrcSpan -> PsMessage -> P () +addPsMessage srcspan msg = do + opts <- options <$> getPState + addWarning ((pMakePsMessage opts) srcspan msg) + addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> @@ -2976,12 +2997,12 @@ addTabWarning srcspan -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account. -getErrorMessages :: PState -> Bag PsError +getErrorMessages :: PState -> Messages PsMessage getErrorMessages p = errors p -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account. -getMessages :: PState -> (Bag PsWarning, Bag PsError) +getMessages :: PState -> (Messages PsMessage, Messages PsMessage) getMessages p = let ws = warnings p -- we add the tabulation warning on the fly because @@ -2989,9 +3010,12 @@ getMessages p = ws' = case tab_first p of Strict.Nothing -> ws Strict.Just tf -> - PsWarnTab (RealSrcSpan tf Strict.Nothing) (tab_count p) - `consBag` ws + let msg = mkMsg (RealSrcSpan tf Strict.Nothing) $ + (PsWarnTab (tab_count p)) + in msg `addMessage` ws in (ws', errors p) + where + mkMsg = pMakePsMessage . options $ p getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx @@ -3037,8 +3061,8 @@ srcParseErr -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token -> SrcSpan - -> PsError -srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc + -> MsgEnvelope PsMessage +srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) where token = lexemeToString (offsetBytes (-len) buf) len pattern_ = decodePrevNChars 8 buf @@ -3047,16 +3071,13 @@ srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc mdoInLast100 = "mdo" `isInfixOf` last100 th_enabled = ThQuotesBit `xtest` pExtsBitmap options ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options - - sug c s = if c then Just s else Nothing - sug_th = sug (not th_enabled && token == "$") (SuggestExtension LangExt.TemplateHaskell) -- #7396 - sug_rdo = sug (token == "<-" && mdoInLast100) (SuggestExtension LangExt.RecursiveDo) - sug_do = sug (token == "<-" && not mdoInLast100) SuggestMissingDo - sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849 - sug_pat = sug (not ps_enabled && pattern_ == "pattern ") (SuggestExtension LangExt.PatternSynonyms) -- #12429 - suggests - | null token = [] - | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat] + details = PsErrParseDetails { + ped_th_enabled = th_enabled + , ped_do_in_last_100 = doInLast100 + , ped_mdo_in_last_100 = mdoInLast100 + , ped_pat_syn_enabled = ps_enabled + , ped_pattern_parsed = pattern_ == "pattern " + } -- Report a parse failure, giving the span of the previous token as -- the location of the error. This is the entry point for errors @@ -3073,7 +3094,7 @@ lexError e = do loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc (psRealLoc end) buf - (\k -> PsError (PsErrLexer e k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a @@ -3188,8 +3209,9 @@ alternativeLayoutRuleToken t -- This next case is to handle a transitional issue: (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Where) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3198,8 +3220,9 @@ alternativeLayoutRuleToken t -- This next case is to handle a transitional issue: (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Pipe) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3322,7 +3345,7 @@ lexToken = do return (L span ITeof) AlexError (AI loc2 buf) -> reportLexError (psRealLoc loc1) (psRealLoc loc2) buf - (\k -> PsError (PsErrLexer LexError k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) AlexSkip inp2 _ -> do setInput inp2 lexToken @@ -3336,7 +3359,11 @@ lexToken = do if (isComment lt') then setLastComment lt else setLastTk lt return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a +reportLexError :: RealSrcLoc + -> RealSrcLoc + -> StringBuffer + -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage) + -> P a reportLexError loc1 loc2 buf f | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) | otherwise = diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 261967be85..e29a8314ff 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -58,7 +58,9 @@ module GHC.Parser.PostProcess ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat - checkPattern_hints, + checkPattern_details, + incompleteDoBlock, + ParseContext(..), checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, @@ -119,12 +121,13 @@ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic -import GHC.Types.Error ( GhcHint(..) ) +import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( isLexCon ) import GHC.Types.TyThing import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) @@ -138,16 +141,14 @@ import GHC.Data.OrdList import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.Bag +import GHC.Utils.Error import GHC.Utils.Misc import Data.Either import Data.List ( findIndex ) import Data.Foldable -import GHC.Driver.Flags ( WarningFlag(..) ) import qualified Data.Semigroup as Semi import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import qualified GHC.LanguageExtensions as LangExt import qualified GHC.Data.Strict as Strict import Control.Monad @@ -275,12 +276,14 @@ mkStandaloneKindSig loc lhs rhs anns = check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v - else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v) + else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $ + (PsErrUnexpectedQualifiedConstructor (unLoc v)) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v - _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) + _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $ + (PsErrMultipleNamesInStandaloneKindSignature vs) mkTyFamInstEqn :: SrcSpan -> HsOuterFamEqnTyVarBndrs GhcPs @@ -409,7 +412,8 @@ mkRoleAnnotDecl loc tycon roles anns let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in - addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role + addFatalError $ mkPlainErrorMsgEnvelope loc_role $ + (PsErrIllegalRoleName role nearby) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if @@ -429,7 +433,8 @@ fromSpecTyVarBndr bndr = case bndr of where check_spec :: Specificity -> SrcSpanAnnA -> P () check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc) + check_spec InferredSpec loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrInferredTypeVarNotAllowed -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ annBinds :: AddEpAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs @@ -508,7 +513,7 @@ cvBindsAndSigs fb = do -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -618,14 +623,14 @@ constructor, a type, or a context, we would need unlimited lookahead which -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] -tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName) +tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) tyConToDataCon (L loc tc) | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = Left $ PsError (PsErrNotADataCon tc) [] (locA loc) + = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) where occ = rdrNameOcc tc @@ -666,17 +671,21 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = fromDecl (L loc decl) = extraDeclErr (locA loc) decl extraDeclErr loc decl = - addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) wrongNameBindingErr loc decl = - addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) wrongNumberErr loc = - addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrEmptyWhereInPatSynDecl patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = - addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrRecordSyntaxInPatSynDecl pat) mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs @@ -817,7 +826,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} -eitherToP :: MonadP m => Either PsError a -> m a +eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing @@ -831,9 +840,11 @@ checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where - check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc) + check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) check (HsValArg ty) = chkParens [] emptyComments ty - check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp + check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ + (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddEpAnn]) @@ -853,7 +864,8 @@ checkTyVars pp_what equals_or_where tc tparms | isRdrTyVar tv = return (L (widenLocatedAn l an) (UserTyVar (addAnns ann an cs) () (L ltv tv))) chk _ _ t@(L loc _) - = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc) + = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) whereDots, equalsDots :: SDoc @@ -865,7 +877,8 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ + (PsErrIllegalDataTypeContext c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) @@ -895,13 +908,15 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc)) + (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrParseErrorOnInput occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrIllegalTraditionalRecordSyntax (ppr r)) return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for @@ -910,7 +925,8 @@ checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs]) -> P (Located ([AddEpAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax - unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span + unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $ + PsErrIllegalWhereInDataDecl return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. @@ -933,7 +949,7 @@ checkTyClHdr is_cls ty -- workaround to define '*' despite StarIsType go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix - = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l)) + = do { addPsMessage (locA l) PsWarnStarBinder ; let name = mkOccName tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix @@ -955,7 +971,8 @@ checkTyClHdr is_cls ty | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) go l _ _ _ _ - = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l + = addFatalError $ mkPlainErrorMsgEnvelope l $ + (PsErrMalformedTyOrClDecl ty) -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName @@ -1003,7 +1020,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ - addError $ PsError (err a) [] (getLocA a) + addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) -- | Validate the context constraints and break up a context into a list -- of predicates. @@ -1077,8 +1094,8 @@ checkImportDecl mPre mPost = do checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [GhcHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) -checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) +checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] @@ -1092,11 +1109,10 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args , pat_args = PrefixCon tyargs args } | not (null tyargs) = - add_hint TypeApplicationsInPatternsOnlyDataCons $ - patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) - | not (null args) && patIsRec c = - add_hint (SuggestExtension LangExt.RecursiveDo) $ - patFail (locA l) (ppr e) + patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs + | (not (null args) && patIsRec c) = do + ctx <- askParseContext + patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do @@ -1105,7 +1121,9 @@ checkPat loc (L _ (PatBuilderApp f e)) [] args = do checkPat loc (L l e) [] [] = do p <- checkAPat loc e return (L l p) -checkPat loc e _ _ = patFail (locA loc) (ppr e) +checkPat loc e _ _ = do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat (unLoc e) details) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do @@ -1130,7 +1148,7 @@ checkAPat loc e0 = do -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do - addError $ PsError PsErrAtInPatPos [] (getLocA op) + addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos return (WildPat noExtField) PatBuilderOpApp l (L cl c) r anns @@ -1147,7 +1165,9 @@ checkAPat loc e0 = do p <- checkLPat e return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) - _ -> patFail (locA loc) (ppr e0) + _ -> do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat e0 details) placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer @@ -1164,8 +1184,8 @@ checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) return (L l (fld { hfbRHS = p })) -patFail :: SrcSpan -> SDoc -> PV a -patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc +patFail :: SrcSpan -> PsMessage -> PV a +patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") @@ -1204,7 +1224,7 @@ checkFunBind :: SrcStrictness -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkFunBind strictness locF ann fun is_infix pats (L _ grhss) - = do ps <- runPV_hints param_hints (mapM checkLPat pats) + = do ps <- runPV_details extraDetails (mapM checkLPat pats) let match_span = noAnnSrcSpan $ locF cs <- getCommentsFor locF return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) @@ -1218,9 +1238,9 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where - param_hints - | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)] - | otherwise = [] + extraDetails + | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock + | otherwise = noParseContext makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs @@ -1260,11 +1280,11 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) = return lrdr checkValSigLhs lhs@(L l _) - = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l) + = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) - => (a -> Bool -> b -> Bool -> c -> PsErrorDesc) + => (a -> Bool -> b -> Bool -> c -> PsMessage) -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do @@ -1274,7 +1294,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr semiElse (unLoc elseExpr) loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) - unless doAndIfThenElse $ addError (PsError e [] loc) + unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) | otherwise = return () isFunLhs :: LocatedA (PatBuilder GhcPs) @@ -1390,7 +1410,7 @@ instance DisambInfixOp (HsExpr GhcPs) where instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l + mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole type AnnoBody b = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan @@ -1554,7 +1574,8 @@ instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ + PsErrOverloadedRecordDotInvalid mkHsLamPV l mg = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) @@ -1590,7 +1611,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsDoPV l Nothing stmts anns = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts) - mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l + mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) @@ -1605,7 +1626,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ @@ -1624,17 +1645,17 @@ instance DisambECP (HsCmd GhcPs) where rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a -cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc +cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do - when (null (hsLMatchPats matches)) $ addError $ PsError PsErrEmptyLambda [] l + when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda checkLamMatchGroup _ _ = return () instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do - addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c return (L l (hsHoleExpr noAnn)) ecpFromExp' = return mkHsProjUpdatePV l fields arg isPun anns = do @@ -1708,19 +1729,20 @@ instance DisambECP (HsExpr GhcPs) where mkHsSectionR_PV l op e = do cs <- getCommentsFor l return $ L l (SectionR (comment (realSrcSpan l) cs) op e) - mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l) + mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsAsPatPV l v e _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) + mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsLazyPatPV l e _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) + mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsBangPatPV l e _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l) + mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e - rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l) + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrUnallowedPragma prag) rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs @@ -1733,19 +1755,19 @@ type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanA instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l) - ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l) - mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l - mkHsLetPV l _ _ _ = addFatalError $ PsError PsErrLetInPat [] l - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c + ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e + mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat + mkHsLetPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = do cs <- getCommentsFor l let anns = EpAnn (spanAsAnchor l) [] cs return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns - mkHsCasePV l _ _ _ = addFatalError $ PsError PsErrCaseInPat [] l - mkHsLamCasePV l _ _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l + mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat + mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) @@ -1753,8 +1775,8 @@ instance DisambECP (PatBuilder GhcPs) where cs <- getCommentsFor (locA l) let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) - mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l - mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat + mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do @@ -1774,7 +1796,7 @@ instance DisambECP (PatBuilder GhcPs) where mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid else do cs <- getCommentsFor l r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs) @@ -1782,11 +1804,11 @@ instance DisambECP (PatBuilder GhcPs) where mkHsNegAppPV l (L lp p) anns = do lit <- case p of PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit) - _ -> patFail l (text "-" <> ppr p) + _ -> patFail l $ PsErrInPat p PEIP_NegApp cs <- getCommentsFor l let an = EpAnn (spanAsAnchor l) anns cs return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) - mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) + mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) mkHsViewPatPV l a b anns = do p <- checkLPat b cs <- getCommentsFor l @@ -1812,7 +1834,8 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 - -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc + -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedStringInPat lit) _ -> return () mkPatRec :: @@ -1829,7 +1852,8 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns , pat_args = RecCon (HsRecFields fs dd) } mkPatRec p _ _ = - addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p) + addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + (PsErrInvalidRecordCon (unLoc p)) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor. @@ -1892,7 +1916,8 @@ instance DisambTD DataConBuilder where panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs l_at ki = - addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at + addFatalError $ mkPlainErrorMsgEnvelope l_at $ + (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) mkHsOpTyPV lhs tc rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative @@ -1902,7 +1927,8 @@ instance DisambTD DataConBuilder where l = combineLocsA lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) = - addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff @@ -1913,7 +1939,7 @@ instance DisambTD DataConBuilder where let l = combineLocsA (reLocA unpk) constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise = - do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk) + do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon return constr_stuff tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) @@ -1924,7 +1950,8 @@ tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t = - addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t) + addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $ + (PsErrInvalidDataCon (unLoc t)) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2373,7 +2400,7 @@ checkPrecP checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () - | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l + | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) where -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR @@ -2391,10 +2418,12 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps)) + then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $ + PsErrOverloadedRecordDotInvalid else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns - | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc + | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ + PsErrDotsInRecordUpdate | otherwise = mkRdrRecordUpd overloaded_update exp fs anns mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) @@ -2408,7 +2437,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do case overloaded_on of False | not $ null ps -> -- A '.' was found in an update and OverloadedRecordUpdate isn't on. - addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc) + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled False -> -- This is just a regular record update. return RecordUpd { @@ -2422,7 +2451,8 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do ] if not $ null qualifiedFields then - addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) + addFatalError $ mkPlainErrorMsgEnvelope (getLoc (head qualifiedFields)) $ + PsErrOverloadedRecordUpdateNoQualifiedFields else -- This is a RecordDotSyntax update. return RecordUpd { rupd_ext = anns @@ -2505,7 +2535,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of - Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc + Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + PsErrMalformedEntityString Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in @@ -2646,12 +2677,14 @@ mkModuleImpExp anns (L l specname) subs = do in (\newName -> IEThingWith ann (L l newName) pos ies) <$> nameT - else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l) + else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPatSynExport where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l) + then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrVarForTyCon name) else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln @@ -2668,7 +2701,8 @@ mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space -> P (LocatedN RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $ + PsErrIllegalExplicitNamespace return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs]) @@ -2678,7 +2712,7 @@ checkImportSpec ie@(L _ specs) = (l:_) -> importSpecError (locA l) where importSpecError l = - addFatalError $ PsError PsErrIllegalImportBundleForm [] l + addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm -- In the correct order mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) @@ -2699,21 +2733,24 @@ isImpExpQcWildcard _ = False warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span = - addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span) + addPsMessage span PsWarnImportPreQualified failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc +failOpNotEnabledImportQualifiedPost loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc +failOpImportQualifiedTwice loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice warnStarIsType :: SrcSpan -> P () -warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span) +warnStarIsType span = addPsMessage span PsWarnStarIsType failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit - ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) } + ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrOpFewArgs (StarIsType star_is_type) op) } ----------------------------------------------------------------------------- -- Misc utils @@ -2721,13 +2758,13 @@ failOpFewArgs (L loc op) = data PV_Context = PV_Context { pv_options :: ParserOpts - , pv_hints :: [GhcHint] -- See Note [Parser-Validator Hint] + , pv_details :: ParseContext -- See Note [Parser-Validator Details] } data PV_Accum = PV_Accum - { pv_warnings :: Bag PsWarning - , pv_errors :: Bag PsError + { pv_warnings :: Messages PsMessage + , pv_errors :: Messages PsMessage , pv_header_comments :: Strict.Maybe [LEpaComment] , pv_comment_q :: [LEpaComment] } @@ -2769,15 +2806,18 @@ instance Monad PV where PV_Failed acc' -> PV_Failed acc' runPV :: PV a -> P a -runPV = runPV_hints [] +runPV = runPV_details noParseContext -runPV_hints :: [GhcHint] -> PV a -> P a -runPV_hints hints m = +askParseContext :: PV ParseContext +askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details + +runPV_details :: ParseContext -> PV a -> P a +runPV_details details m = P $ \s -> let pv_ctx = PV_Context { pv_options = options s - , pv_hints = hints } + , pv_details = details } pv_acc = PV_Accum { pv_warnings = warnings s , pv_errors = errors s @@ -2792,22 +2832,14 @@ runPV_hints hints m = PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: GhcHint -> PV a -> PV a -add_hint hint m = - let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in - PV (\ctx acc -> unPV m (modifyHint ctx) acc) - instance MonadP PV where - addError err@(PsError e hints loc) = - PV $ \ctx acc -> - let err' | null (pv_hints ctx) = err - | otherwise = PsError e (hints ++ pv_hints ctx) loc - in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} () - addWarning option w = - PV $ \ctx acc -> - if warnopt option (pv_options ctx) - then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} () - else PV_Ok acc () + addError err = + PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} () + addWarning w = + PV $ \_ctx acc -> + -- No need to check for the warning flag to be set, GHC will correctly discard suppressed + -- diagnostics. + PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () addFatalError err = addError err >> PV (const PV_Failed) getBit ext = @@ -2834,9 +2866,9 @@ instance MonadP PV where pv_comment_q = comment_q' } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) -{- Note [Parser-Validator Hint] +{- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parametrized by a hint for error messages, which can be set +A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984. Consider this example, where the user has forgotten a 'do': @@ -2863,16 +2895,17 @@ Note that this fragment is parsed as a pattern: _ -> result -We attempt to detect such cases and add a hint to the error messages: +We attempt to detect such cases and add a hint to the diagnostic messages: T984.hs:6:9: Parse error in pattern: case () of { _ -> result } Possibly caused by a missing 'do'? -The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed -as the 'pv_hints' field 'PV_Context'. When validating in a context other than -'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has -no effect on the error messages. +The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed +out of the 'ParseContext', which are read by functions like 'patFail' when +constructing the 'PsParseErrorInPatDetails' data structure. When validating in a +context other than 'bindpat' (a pattern to the left of <-), we set the +details to 'noParseContext' and it has no effect on the diagnostic messages. -} @@ -2881,7 +2914,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ - addError $ PsError (PsErrIllegalBangPattern e) [] span + addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) -> [AddEpAnn] @@ -2907,7 +2940,7 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do cs <- getCommentsFor (locA l) return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} _ = - addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l) + addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a mkSumOrTuplePat :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn] @@ -2923,7 +2956,8 @@ mkSumOrTuplePat l boxity (Tuple ps) anns = do -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. toTupPat p = case p of - Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l) + Left _ -> addFatalError $ + mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat Right p' -> checkLPat p' -- Sum @@ -2933,7 +2967,8 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs return $ L l (PatBuilderPat (SumPat an p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} _ = - addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l) + addFatalError $ + mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 301e902f8b..88988b2ea6 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -54,7 +54,6 @@ import GHC.Prelude hiding (mod) import GHC.Hs import GHC.Types.SrcLoc -import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic import GHC.Data.Bag @@ -71,7 +70,7 @@ import Data.Coerce import qualified Data.Monoid import GHC.Parser.Lexer -import GHC.Parser.Errors +import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) import qualified GHC.Data.Strict as Strict @@ -193,9 +192,9 @@ addHaddockToModule lmod = do reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) = - addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l) + addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos reportHdkWarning (HdkWarnExtraComment (L l _)) = - addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l + addPsMessage l PsWarnHaddockIgnoreMulti collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } = diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 23e00acfd8..51cd77b33a 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -5,7 +5,6 @@ module GHC.Types.Hint where import GHC.Prelude import GHC.Utils.Outputable -import GHC.Types.Name.Reader import GHC.LanguageExtensions import Data.Typeable import GHC.Unit.Module (ModuleName, Module) @@ -47,12 +46,6 @@ data GhcHint Test cases: None (that explicitly test this particular hint is emitted). -} | SuggestLetInDo - -- FIXME(adn) This is not a hint but was migrated from the old \"PsHint\" type. - -- It will be removed in a further refactoring as part of #18516. - | SuggestInfixBindMaybeAtPat !RdrName - -- FIXME(adn) This is not a hint but was migrated from the old \"PsHint\" type. - -- It will be removed in a further refactoring as part of #18516. - | TypeApplicationsInPatternsOnlyDataCons {-| Suggests to add an \".hsig\" signature file to the Cabal manifest. Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal @@ -75,6 +68,20 @@ data GhcHint Test case(s): driver/T12955 -} | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion] + {-| Suggests to use spaces instead of tabs. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'. + + Examples: None + Test Case(s): None + -} + | SuggestUseSpaces + {-| Suggests wrapping an expression in parentheses + + Examples: None + Test Case(s): None + -} + | SuggestParentheses instance Outputable GhcHint where @@ -88,15 +95,6 @@ instance Outputable GhcHint where SuggestLetInDo -> text "Perhaps you need a 'let' in a 'do' block?" $$ text "e.g. 'let x = 5' instead of 'x = 5'" - SuggestInfixBindMaybeAtPat fun - -> text "In a function binding for the" - <+> quotes (ppr fun) - <+> text "operator." - $$ if opIsAt fun - then perhapsAsPat - else empty - TypeApplicationsInPatternsOnlyDataCons - -> text "Type applications in patterns are only allowed on data constructors." SuggestAddSignatureCabalFile pi_mod_name -> text "Try adding" <+> quotes (ppr pi_mod_name) <+> text "to the" @@ -111,10 +109,10 @@ instance Outputable GhcHint where in text "Try passing -instantiated-with=\"" <> suggested_instantiated_with <> text "\"" $$ text "replacing <" <> ppr pi_mod_name <> text "> as necessary." - -perhapsAsPat :: SDoc -perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" - + SuggestUseSpaces + -> text "Please use spaces instead." + SuggestParentheses + -> text "Use parentheses." -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 29762bd79f..ae596cd48e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -476,7 +476,6 @@ Library GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass - GHC.Parser.Errors GHC.Parser.Errors.Ppr GHC.Parser.Errors.Types GHC.Parser.Header diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr index 7af5fb086f..2ca8354a91 100644 --- a/testsuite/tests/driver/werror.stderr +++ b/testsuite/tests/driver/werror.stderr @@ -11,7 +11,7 @@ werror.hs:7:13: error: [-Wname-shadowing (in -Wall), -Werror=name-shadowing] werror.hs:8:1: error: [-Wtabs (in -Wdefault), -Werror=tabs] Tab character found here. - Please use spaces instead. + Suggested fix: Please use spaces instead. werror.hs:10:1: error: [-Wmissing-signatures (in -Wall), -Werror=missing-signatures] Top-level binding with no type signature: f :: [a1] -> [a2] diff --git a/testsuite/tests/mdo/should_fail/mdofail005.stderr b/testsuite/tests/mdo/should_fail/mdofail005.stderr index 0ebead149f..18e2e4ae9d 100644 --- a/testsuite/tests/mdo/should_fail/mdofail005.stderr +++ b/testsuite/tests/mdo/should_fail/mdofail005.stderr @@ -1,4 +1,4 @@ mdofail005.hs:11:14: error: parse error on input ‘<-’ - Perhaps you intended to use RecursiveDo + Suggested fix: Perhaps you intended to use RecursiveDo diff --git a/testsuite/tests/parser/should_compile/T9723a.stderr b/testsuite/tests/parser/should_compile/T9723a.stderr index e3a2ede74f..5fdfdd9f22 100644 --- a/testsuite/tests/parser/should_compile/T9723a.stderr +++ b/testsuite/tests/parser/should_compile/T9723a.stderr @@ -1,4 +1,4 @@ T9723a.hs:8:5: warning: [-Wtabs (in -Wdefault)] Tab character found here. - Please use spaces instead. + Suggested fix: Please use spaces instead. diff --git a/testsuite/tests/parser/should_compile/T9723b.stderr b/testsuite/tests/parser/should_compile/T9723b.stderr index 380b2d8f88..c83b48e8a4 100644 --- a/testsuite/tests/parser/should_compile/T9723b.stderr +++ b/testsuite/tests/parser/should_compile/T9723b.stderr @@ -1,4 +1,4 @@ T9723b.hs:10:5: warning: [-Wtabs (in -Wdefault)] Tab character found here, and in six further locations. - Please use spaces instead. + Suggested fix: Please use spaces instead. diff --git a/testsuite/tests/parser/should_compile/read043.stderr b/testsuite/tests/parser/should_compile/read043.stderr index 9e792e7409..a551294064 100644 --- a/testsuite/tests/parser/should_compile/read043.stderr +++ b/testsuite/tests/parser/should_compile/read043.stderr @@ -1,4 +1,4 @@ read043.hs:8:5: warning: [-Wtabs (in -Wdefault)] Tab character found here, and in one further location. - Please use spaces instead. + Suggested fix: Please use spaces instead. diff --git a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr index f50166fd41..4651dae571 100644 --- a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr +++ b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr @@ -1,4 +1,3 @@ InfixAppPatErr.hs:2:7: error: do-notation in pattern - Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr index 813271bdb9..bdb3301dea 100644 --- a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr @@ -2,5 +2,6 @@ NoBlockArgumentsFail.hs:6:17: error: Unexpected do block in function application: do return () - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr index 0361369774..5b3a697f2e 100644 --- a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr @@ -2,5 +2,6 @@ NoBlockArgumentsFail2.hs:6:22: error: Unexpected lambda expression in function application: \ x -> print x - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr index e285e6ea72..93a3c99d49 100644 --- a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr @@ -2,5 +2,6 @@ NoBlockArgumentsFail3.hs:7:22: error: Unexpected lambda-case expression in function application: \case Just 3 -> print x - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.stderr index 2a99cda137..504f4c738f 100644 --- a/testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.stderr +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.stderr @@ -2,5 +2,6 @@ NoBlockArgumentsFailArrowCmds.hs:7:27: error: Unexpected lambda command in function application: \ () -> () >- returnA - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments diff --git a/testsuite/tests/parser/should_fail/T12429.stderr b/testsuite/tests/parser/should_fail/T12429.stderr index e29388f3e5..eab51a5646 100644 --- a/testsuite/tests/parser/should_fail/T12429.stderr +++ b/testsuite/tests/parser/should_fail/T12429.stderr @@ -1,4 +1,4 @@ T12429.hs:2:29: error: parse error on input ‘Y’ - Perhaps you intended to use PatternSynonyms + Suggested fix: Perhaps you intended to use PatternSynonyms diff --git a/testsuite/tests/parser/should_fail/T12610.stderr b/testsuite/tests/parser/should_fail/T12610.stderr index 29d9b26cf2..2eb924bfb0 100644 --- a/testsuite/tests/parser/should_fail/T12610.stderr +++ b/testsuite/tests/parser/should_fail/T12610.stderr @@ -1,6 +1,6 @@ T12610.hs:5:1: warning: [-Wtabs (in -Wdefault)] Tab character found here. - Please use spaces instead. + Suggested fix: Please use spaces instead. T12610.hs:5:9: parse error on input ‘y’ diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr index 323d9c93e3..40a986879e 100644 --- a/testsuite/tests/parser/should_fail/T16270.stderr +++ b/testsuite/tests/parser/should_fail/T16270.stderr @@ -4,7 +4,7 @@ T16270.hs:3:13: warning: [-Wdeprecated-flags (in -Wdefault)] T16270.hs:8:1: warning: [-Wtabs (in -Wdefault)] Tab character found here, and in five further locations. - Please use spaces instead. + Suggested fix: Please use spaces instead. T16270.hs:8:12: error: Unexpected semi-colons in conditional: @@ -14,14 +14,16 @@ T16270.hs:8:12: error: T16270.hs:13:8: error: Unexpected do block in function application: do 1 - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments T16270.hs:14:8: error: Unexpected lambda expression in function application: \ x -> x - You could write it with parentheses - Or perhaps you meant to enable BlockArguments? + Suggested fixes: + Use parentheses. + Perhaps you intended to use BlockArguments T16270.hs:18:22: error: Illegal record syntax (use TraditionalRecordSyntax): {fst :: a, diff --git a/testsuite/tests/parser/should_fail/T8501a.stderr b/testsuite/tests/parser/should_fail/T8501a.stderr index 44431fca77..1c899e8bca 100644 --- a/testsuite/tests/parser/should_fail/T8501a.stderr +++ b/testsuite/tests/parser/should_fail/T8501a.stderr @@ -1,5 +1,6 @@ T8501a.hs:5:3: error: Parse error in pattern: rec - Possibly caused by a missing 'do'? - Perhaps you intended to use RecursiveDo + Suggested fixes: + Perhaps you intended to use RecursiveDo + Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/T8501b.stderr b/testsuite/tests/parser/should_fail/T8501b.stderr index e9e4b5ec91..15a631c177 100644 --- a/testsuite/tests/parser/should_fail/T8501b.stderr +++ b/testsuite/tests/parser/should_fail/T8501b.stderr @@ -1,4 +1,4 @@ T8501b.hs:5:9: error: parse error on input ‘<-’ - Perhaps you intended to use RecursiveDo + Suggested fix: Perhaps you intended to use RecursiveDo diff --git a/testsuite/tests/parser/should_fail/T984.stderr b/testsuite/tests/parser/should_fail/T984.stderr index 6d25a36e9e..aaa4f532a9 100644 --- a/testsuite/tests/parser/should_fail/T984.stderr +++ b/testsuite/tests/parser/should_fail/T984.stderr @@ -1,4 +1,3 @@ T984.hs:6:9: error: (case ... of ...)-syntax in pattern - Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/readFail007.stderr b/testsuite/tests/parser/should_fail/readFail007.stderr index bd6d92ed58..ab4140f52a 100644 --- a/testsuite/tests/parser/should_fail/readFail007.stderr +++ b/testsuite/tests/parser/should_fail/readFail007.stderr @@ -1,4 +1,4 @@ readFail007.hs:6:4: Parse error in pattern: 2 + 2 - Possibly caused by a missing 'do'? + Suggested fix: Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/readFail040.stderr b/testsuite/tests/parser/should_fail/readFail040.stderr index 663220da26..3ba58a4adb 100644 --- a/testsuite/tests/parser/should_fail/readFail040.stderr +++ b/testsuite/tests/parser/should_fail/readFail040.stderr @@ -1,4 +1,4 @@ readFail040.hs:7:11: error: parse error on input ‘<-’ - Perhaps you intended to use RecursiveDo + Suggested fix: Perhaps you intended to use RecursiveDo diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index c898dd7424..51df841ab0 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 258 Language.Haskell.Syntax module dependencies +Found 257 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -114,7 +114,6 @@ GHC.Iface.Syntax GHC.Iface.Type GHC.Linker.Types GHC.Parser.Annotation -GHC.Parser.Errors GHC.Parser.Errors.Ppr GHC.Parser.Errors.Types GHC.Parser.Types diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 05d6073262..bfd270bf00 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 264 GHC.Parser module dependencies +Found 263 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -117,7 +117,6 @@ GHC.Linker.Types GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass -GHC.Parser.Errors GHC.Parser.Errors.Ppr GHC.Parser.Errors.Types GHC.Parser.Lexer diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index 4e84261264..f68cd040df 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -120,11 +120,9 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do -- parse the cmm file and output any warnings or errors let fake_mod = mkHomeModule (hsc_home_unit hscEnv) (mkModuleName "fake") (warnings, errors, parsedCmm) <- parseCmmFile dflags fake_mod (hsc_home_unit hscEnv) cmmFile - let warningMsgs = fmap (mkParserWarn dflags') warnings - errorMsgs = fmap mkParserErr errors -- print parser errors or warnings - mapM_ (printMessages logger dflags . mkMessages) [warningMsgs, errorMsgs] + mapM_ (printMessages logger dflags) [warnings, errors] let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fst $ fromJust parsedCmm diff --git a/testsuite/tests/warnings/should_compile/T9230.stderr b/testsuite/tests/warnings/should_compile/T9230.stderr index 14458ff5c3..208002033b 100644 --- a/testsuite/tests/warnings/should_compile/T9230.stderr +++ b/testsuite/tests/warnings/should_compile/T9230.stderr @@ -1,4 +1,4 @@ T9230.hs:5:1: warning: [-Wtabs (in -Wdefault)] Tab character found here. - Please use spaces instead. + Suggested fix: Please use spaces instead. diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index 11005a05cb..4620ae3fa1 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -60,7 +60,6 @@ import qualified GHC.Parser as GHC import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Parser.PostProcess as GHC -import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.LanguageExtensions as LangExt @@ -77,7 +76,7 @@ parseWith :: GHC.DynFlags parseWith dflags fileName parser s = case runParser parser dflags fileName s of GHC.PFailed pst - -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + -> Left (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) GHC.POk _ pmod -> Right pmod @@ -91,7 +90,7 @@ parseWithECP :: (GHC.DisambECP w) parseWithECP dflags fileName parser s = case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of GHC.PFailed pst - -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + -> Left (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) GHC.POk _ pmod -> Right pmod @@ -184,7 +183,7 @@ parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of GHC.PFailed pst - -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + -> Left (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) GHC.POk _ pmod -> Right (lp, dflags, pmod) in postParseTransform res @@ -257,7 +256,7 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file = do return $ case parseFile dflags' file fileContents of GHC.PFailed pst - -> Left (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + -> Left (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) GHC.POk _ pmod -> Right $ (injectedComments, dflags', pmod) diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index 17ec766b20..245305a677 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -24,7 +24,6 @@ import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Fingerprint.Type as GHC -import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer as GHC hiding (getMessages) import qualified GHC.Settings as GHC import qualified GHC.Types.Error as GHC (getMessages) @@ -280,8 +279,7 @@ parseError pst = do let -- (warns,errs) = GHC.getMessages pst dflags -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) - GHC.throwErrors $ - (GHC.foldPsMessages GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.throwErrors $ (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) -- --------------------------------------------------------------------- diff --git a/utils/haddock b/utils/haddock -Subproject 804254a541d800ef983df7c98426014ff94430d +Subproject 4f9088e4b04e52ca510b55a78048c9230537e44 |