summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
authorAlfredo Di Napoli <alfredo@well-typed.com>2021-04-19 14:29:18 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-05-26 16:03:15 -0400
commitcdbce8fc22448837e53515946f16e9571e06f412 (patch)
treea07372a960e55eaeff036ed717272b47f821711b /compiler/GHC
parent2023b344a7567492881745609c494a9427dc8c30 (diff)
downloadhaskell-cdbce8fc22448837e53515946f16e9571e06f412.tar.gz
Support new parser types in GHC
This commit converts the lexers and all the parser machinery to use the new parser types and diagnostics infrastructure. Furthermore, it cleans up the way the parser code was emitting hints. As a result of this systematic approach, the test output of the `InfixAppPatErr` and `T984` tests have been changed. Previously they would emit a `SuggestMissingDo` hint, but this was not at all helpful in resolving the error, and it was even confusing by just looking at the original program that triggered the errors. Update haddock submodule
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Cmm/Lexer.x8
-rw-r--r--compiler/GHC/Cmm/Parser.y26
-rw-r--r--compiler/GHC/Cmm/Parser/Monad.hs5
-rw-r--r--compiler/GHC/Driver/Backpack.hs3
-rw-r--r--compiler/GHC/Driver/Config.hs2
-rw-r--r--compiler/GHC/Driver/Errors.hs8
-rw-r--r--compiler/GHC/Driver/Errors/Ppr.hs10
-rw-r--r--compiler/GHC/Driver/Errors/Types.hs12
-rw-r--r--compiler/GHC/Driver/Main.hs38
-rw-r--r--compiler/GHC/Driver/Make.hs2
-rw-r--r--compiler/GHC/Driver/Pipeline.hs3
-rw-r--r--compiler/GHC/Parser.y30
-rw-r--r--compiler/GHC/Parser/Errors.hs421
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs1210
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs499
-rw-r--r--compiler/GHC/Parser/Header.hs9
-rw-r--r--compiler/GHC/Parser/Lexer.x165
-rw-r--r--compiler/GHC/Parser/PostProcess.hs285
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs7
-rw-r--r--compiler/GHC/Types/Hint.hs38
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
View Lorry Controller Status