diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Cmm/Lexer.x | 8 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Parser.y | 26 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Parser/Monad.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors/Ppr.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors/Types.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 38 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Make.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Parser.y | 30 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors.hs | 421 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 1210 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 499 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Header.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 165 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 285 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Types/Hint.hs | 38 |
20 files changed, 1524 insertions, 1257 deletions
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 |