summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC.hs21
-rw-r--r--compiler/GHC/Builtin/Types.hs9
-rw-r--r--compiler/GHC/Cmm/Lexer.x3
-rw-r--r--compiler/GHC/Cmm/Monad.hs4
-rw-r--r--compiler/GHC/Cmm/Parser.y34
-rw-r--r--compiler/GHC/Driver/Backpack.hs3
-rw-r--r--compiler/GHC/Driver/Main.hs30
-rw-r--r--compiler/GHC/Driver/Make.hs6
-rw-r--r--compiler/GHC/Driver/Pipeline.hs3
-rw-r--r--compiler/GHC/Parser.y47
-rw-r--r--compiler/GHC/Parser/Annotation.hs7
-rw-r--r--compiler/GHC/Parser/Errors.hs404
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs585
-rw-r--r--compiler/GHC/Parser/Header.hs16
-rw-r--r--compiler/GHC/Parser/Lexer.x247
-rw-r--r--compiler/GHC/Parser/PostProcess.hs544
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs9
-rw-r--r--compiler/GHC/Parser/Types.hs95
-rw-r--r--compiler/GHC/Rename/Env.hs2
-rw-r--r--compiler/GHC/Types/Name/Reader.hs9
-rw-r--r--compiler/GHC/Utils/Error.hs6
-rw-r--r--compiler/ghc.cabal.in11
22 files changed, 1446 insertions, 649 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 979e42ccc9..be4d29181e 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -357,6 +357,7 @@ import GHC.Data.FastString
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Name.Env
import GHC.Tc.Module
@@ -1430,10 +1431,8 @@ getTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
- POk _ ts -> return ts
- PFailed pst ->
- do dflags <- getDynFlags
- throwErrors (getErrorMessages pst dflags)
+ POk _ ts -> return ts
+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
@@ -1443,10 +1442,8 @@ getRichTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
- POk _ ts -> return $ addSourceToTokens startLoc source ts
- PFailed pst ->
- do dflags <- getDynFlags
- throwErrors (getErrorMessages pst dflags)
+ POk _ ts -> return $ addSourceToTokens startLoc source ts
+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
@@ -1620,12 +1617,12 @@ parser str dflags filename =
case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
- let (warns,errs) = getMessages pst dflags in
- (warns, Left errs)
+ let (warns,errs) = getMessages pst in
+ (fmap pprWarning warns, Left (fmap pprError errs))
POk pst rdr_module ->
- let (warns,_) = getMessages pst dflags in
- (warns, Right rdr_module)
+ let (warns,_) = getMessages pst in
+ (fmap pprWarning warns, Right rdr_module)
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index e211434e60..b254bc233d 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -78,6 +78,7 @@ module GHC.Builtin.Types (
unboxedUnitTy,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedTupleKind, unboxedSumKind,
+ filterCTuple,
-- ** Constraint tuples
cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
@@ -2029,3 +2030,11 @@ naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon
naturalNBDataCon :: DataCon
naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon
+
+
+-- | Replaces constraint tuple names with corresponding boxed ones.
+filterCTuple :: RdrName -> RdrName
+filterCTuple (Exact n)
+ | Just arity <- cTupleTyConNameArity_maybe n
+ = Exact $ tupleTyConName BoxedTuple arity
+filterCTuple rdr = rdr
diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index 010001cd2a..956107e61e 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -26,6 +26,7 @@ import GHC.Types.Unique.FM
import GHC.Data.StringBuffer
import GHC.Data.FastString
import GHC.Parser.CharClass
+import GHC.Parser.Errors
import GHC.Utils.Misc
--import TRACE
@@ -325,7 +326,7 @@ 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) "lexical error"
+ AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (Error ErrCmmLexer [])
AlexSkip inp2 _ -> do
setInput inp2
lexToken
diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs
index edb4c5f9d6..7cee74cd34 100644
--- a/compiler/GHC/Cmm/Monad.hs
+++ b/compiler/GHC/Cmm/Monad.hs
@@ -26,6 +26,8 @@ import Control.Monad
import GHC.Driver.Session
import GHC.Parser.Lexer
+import GHC.Parser.Errors
+import GHC.Types.SrcLoc
newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
@@ -42,7 +44,7 @@ instance Monad PD where
liftP :: P a -> PD a
liftP (P f) = PD $ \_ s -> f s
-failMsgPD :: String -> PD a
+failMsgPD :: (SrcSpan -> Error) -> PD a
failMsgPD = liftP . failMsgP
returnPD :: a -> PD a
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index e1e89e9977..6bbbdc819b 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -239,6 +239,7 @@ import qualified GHC.Cmm.Monad as PD
import GHC.Cmm.CallConv
import GHC.Runtime.Heap.Layout
import GHC.Parser.Lexer
+import GHC.Parser.Errors
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
@@ -257,7 +258,7 @@ import GHC.Utils.Panic
import GHC.Settings.Constants
import GHC.Utils.Outputable
import GHC.Types.Basic
-import GHC.Data.Bag ( emptyBag, unitBag )
+import GHC.Data.Bag ( Bag, emptyBag, unitBag, isEmptyBag )
import GHC.Types.Var
import Control.Monad
@@ -899,7 +900,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure
nameToMachOp :: FastString -> PD (Width -> MachOp)
nameToMachOp name =
case lookupUFM machOps name of
- Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []
Just m -> return m
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
@@ -1061,12 +1062,12 @@ parseSafety :: String -> PD Safety
parseSafety "safe" = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
-parseSafety str = failMsgPD ("unrecognised safety: " ++ str)
+parseSafety str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedSafety str)) []
parseCmmHint :: String -> PD ForeignHint
parseCmmHint "ptr" = return AddrHint
parseCmmHint "signed" = return SignedHint
-parseCmmHint str = failMsgPD ("unrecognised hint: " ++ str)
+parseCmmHint str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedHint str)) []
-- labels are always pointers, so we might as well infer the hint
inferCmmHint :: CmmExpr -> ForeignHint
@@ -1093,7 +1094,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 ("unknown macro: " ++ unpackFS fun)
+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownMacro fun)) []
Just fcode -> return $ do
args <- sequence args_code
code (fcode args)
@@ -1194,9 +1195,9 @@ foreignCall
-> PD (CmmParse ())
foreignCall conv_string results_code expr_code args_code safety ret
= do conv <- case conv_string of
- "C" -> return CCallConv
+ "C" -> return CCallConv
"stdcall" -> return StdCallConv
- _ -> failMsgPD ("unknown calling convention: " ++ conv_string)
+ _ -> failMsgPD $ Error (ErrCmmParser (CmmUnknownCConv conv_string)) []
return $ do
platform <- getPlatform
results <- sequence results_code
@@ -1274,7 +1275,7 @@ primCall results_code name args_code
= do
platform <- PD.getPlatform
case lookupUFM (callishMachOps platform) name of
- Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
+ Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []
Just f -> return $ do
results <- sequence results_code
args <- sequence args_code
@@ -1428,8 +1429,8 @@ initEnv profile = listToUFM [
]
where platform = profilePlatform profile
-parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
-parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)
+parseCmmFile dflags filename = do
buf <- hGetStringBuffer filename
let
init_loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -1438,16 +1439,17 @@ parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (te
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
case unPD cmmParse dflags init_state of
- PFailed pst ->
- return (getMessages pst dflags, Nothing)
+ PFailed pst -> do
+ let (warnings,errors) = getMessages pst
+ return (warnings, errors, Nothing)
POk pst code -> do
st <- initC
let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
(cmm,_) = runC dflags no_module st fcode
- let ms = getMessages pst dflags
- if (errorsFound dflags ms)
- then return (ms, Nothing)
- else return (ms, Just cmm)
+ (warnings,errors) = getMessages pst
+ if not (isEmptyBag errors)
+ then return (warnings, errors, Nothing)
+ else return (warnings, errors, Just cmm)
where
no_module = panic "parseCmmFile: no module"
}
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 494cffb785..242ecd9aa4 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -24,6 +24,7 @@ import GHC.Prelude
import GHC.Driver.Backpack.Syntax
import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
import GHC hiding (Failed, Succeeded)
import GHC.Parser
import GHC.Parser.Lexer
@@ -85,7 +86,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 (getErrorMessages pst dflags)
+ PFailed pst -> throwErrors (fmap pprError (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/Main.hs b/compiler/GHC/Driver/Main.hs
index 593251a253..a2fa2e2aea 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -101,6 +101,8 @@ import GHC.Utils.Panic
import GHC.Core.ConLike
import GHC.Parser.Annotation
+import GHC.Parser.Errors
+import GHC.Parser.Errors.Ppr
import GHC.Unit
import GHC.Unit.State
import GHC.Types.Name.Reader
@@ -177,7 +179,7 @@ import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
@@ -237,15 +239,19 @@ handleWarnings = do
-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
-logWarningsReportErrors :: Messages -> Hsc ()
-logWarningsReportErrors (warns,errs) = do
+logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc ()
+logWarningsReportErrors (warnings,errors) = do
+ let warns = fmap pprWarning warnings
+ errs = fmap pprError errors
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
-- | Log warnings and throw errors, assuming the messages
-- contain at least one error (e.g. coming from PFailed)
-handleWarningsThrowErrors :: Messages -> Hsc a
-handleWarningsThrowErrors (warns, errs) = do
+handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a
+handleWarningsThrowErrors (warnings, errors) = do
+ let warns = fmap pprWarning warnings
+ errs = fmap pprError errors
logWarnings warns
dflags <- getDynFlags
(wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
@@ -356,9 +362,9 @@ hscParse' mod_summary
case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
- handleWarningsThrowErrors (getMessages pst dflags)
+ handleWarningsThrowErrors (getMessages pst)
POk pst rdr_module -> do
- let (warns, errs) = getMessages pst dflags
+ let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
logWarnings warns
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr rdr_module)
@@ -1496,7 +1502,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
platform = targetPlatform dflags
- cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+ cmm <- ioMsgMaybe
+ $ do
+ (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
+ $ parseCmmFile dflags filename
+ return ((fmap pprWarning warns, fmap pprError errs), cmm)
liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
let -- Make up a module name to give the NCG. We can't pass bottom here
@@ -1878,10 +1888,10 @@ hscParseThingWithLocation source linenumber parser str
case unP parser (initParserState (initParserOpts dflags) buf loc) of
PFailed pst -> do
- handleWarningsThrowErrors (getMessages pst dflags)
+ handleWarningsThrowErrors (getMessages pst)
POk pst thing -> do
- logWarningsReportErrors (getMessages pst dflags)
+ logWarningsReportErrors (getMessages pst)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr thing)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index de1746c815..a40efb74aa 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -45,6 +45,7 @@ import GHC.Utils.Error
import GHC.Driver.Finder
import GHC.Driver.Monad
import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
import GHC.Driver.Types
import GHC.Unit
import GHC.Unit.State
@@ -94,6 +95,7 @@ import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
+import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO ( fixIO )
@@ -2669,7 +2671,9 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
<- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
(pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
- <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+ <- ExceptT $ do
+ mimps <- getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+ return (first (fmap pprError) mimps)
return PreprocessedImports {..}
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 66487c497d..0dd3d0f8fa 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -45,6 +45,7 @@ import GHC.Unit.State
import GHC.Platform.Ways
import GHC.Platform.ArchOS
import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
import GHC.Driver.Phases
import GHC.SysTools
import GHC.SysTools.ExtraObj
@@ -1117,7 +1118,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
buf <- hGetStringBuffer input_fn
eimps <- getImports dflags buf input_fn (basename <.> suff)
case eimps of
- Left errs -> throwErrors errs
+ Left errs -> throwErrors (fmap pprError 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 2984d33631..e61441cdb4 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -85,6 +85,7 @@ import GHC.Parser.PostProcess
import GHC.Parser.PostProcess.Haddock
import GHC.Parser.Lexer
import GHC.Parser.Annotation
+import GHC.Parser.Errors
import GHC.Tc.Types.Evidence ( emptyTcEvBinds )
@@ -797,7 +798,7 @@ HYPHEN :: { [AddAnn] }
| PREFIX_MINUS { [mj AnnMinus $1 ] }
| VARSYM {% if (getVARSYM $1 == fsLit "-")
then return [mj AnnMinus $1]
- else do { addError (getLoc $1) $ text "Expected a hyphen"
+ else do { addError $ Error ErrExpectedHyphen [] (getLoc $1)
; return [] } }
@@ -1094,10 +1095,7 @@ maybe_safe :: { ([AddAnn],Bool) }
maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
: STRING {% do { let { pkgFS = getSTRING $1 }
; unless (looksLikePackageName (unpackFS pkgFS)) $
- addError (getLoc $1) $ vcat [
- text "Parse error" <> colon <+> quotes (ppr pkgFS),
- text "Version number or non-alphanumeric" <+>
- text "character in package name"]
+ addError $ Error (ErrInvalidPackageName pkgFS) [] (getLoc $1)
; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
| {- empty -} { ([],Nothing) }
@@ -1798,7 +1796,7 @@ rule_activation_marker :: { [AddAnn] }
: PREFIX_TILDE { [mj AnnTilde $1] }
| VARSYM {% if (getVARSYM $1 == fsLit "~")
then return [mj AnnTilde $1]
- else do { addError (getLoc $1) $ text "Invalid rule activation marker"
+ else do { addError $ Error ErrInvalidRuleActivationMarker [] (getLoc $1)
; return [] } }
rule_explicit_activation :: { ([AddAnn]
@@ -3216,7 +3214,7 @@ pat : exp {% (checkPattern <=< runPV) (unECP $1) }
bindpat :: { LPat GhcPs }
bindpat : exp {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess
- checkPattern_msg (text "Possibly caused by a missing 'do'?")
+ checkPattern_hints [SuggestMissingDo]
(unECP $1) }
apat :: { LPat GhcPs }
@@ -3840,10 +3838,9 @@ hasE _ = False
getSCC :: Located Token -> P FastString
getSCC lt = do let s = getSTRING lt
- err = "Spaces are not allowed in SCCs"
-- We probably actually want to be more restrictive than this
if ' ' `elem` unpackFS s
- then addFatalError (getLoc lt) (text err)
+ then addFatalError $ Error ErrSpaceInSCC [] (getLoc lt)
else return s
-- Utilities for combining source spans
@@ -3928,8 +3925,7 @@ fileSrcSpan = do
hintLinear :: MonadP m => SrcSpan -> m ()
hintLinear span = do
linearEnabled <- getBit LinearTypesBit
- unless linearEnabled $ addError span $
- text "Enable LinearTypes to allow linear functions"
+ unless linearEnabled $ addError $ Error ErrLinearFunction [] span
-- Does this look like (a %m)?
looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool
@@ -3948,22 +3944,14 @@ looksLikeMult ty1 l_op ty2
hintMultiWayIf :: SrcSpan -> P ()
hintMultiWayIf span = do
mwiEnabled <- getBit MultiWayIfBit
- unless mwiEnabled $ addError span $
- text "Multi-way if-expressions need MultiWayIf turned on"
+ unless mwiEnabled $ addError $ Error ErrMultiWayIf [] span
-- Hint about explicit-forall
hintExplicitForall :: Located Token -> P ()
hintExplicitForall tok = do
forall <- getBit ExplicitForallBit
rulePrag <- getBit InRulePragBit
- unless (forall || rulePrag) $ addError (getLoc tok) $ vcat
- [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"
- , text "Perhaps you intended to use RankNTypes or a similar language"
- , text "extension to enable explicit-forall syntax:" <+>
- forallSymDoc <+> text "<tvs>. <type>"
- ]
- where
- forallSymDoc = text (forallSym (isUnicode tok))
+ unless (forall || rulePrag) $ addError $ Error (ErrExplicitForall (isUnicode tok)) [] (getLoc tok)
-- Hint about qualified-do
hintQualifiedDo :: Located Token -> P ()
@@ -3971,10 +3959,7 @@ hintQualifiedDo tok = do
qualifiedDo <- getBit QualifiedDoBit
case maybeQDoDoc of
Just qdoDoc | not qualifiedDo ->
- addError (getLoc tok) $ vcat
- [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
- , text "Perhaps you intended to use QualifiedDo"
- ]
+ addError $ Error (ErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)
_ -> return ()
where
maybeQDoDoc = case unLoc tok of
@@ -3988,17 +3973,7 @@ hintQualifiedDo tok = do
reportEmptyDoubleQuotes :: SrcSpan -> P a
reportEmptyDoubleQuotes span = do
thQuotes <- getBit ThQuotesBit
- if thQuotes
- then addFatalError span $ vcat
- [ text "Parser error on `''`"
- , text "Character literals may not be empty"
- , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
- , text "but the type variable or constructor is missing"
- ]
- else addFatalError span $ vcat
- [ text "Parser error on `''`"
- , text "Character literals may not be empty"
- ]
+ addFatalError $ Error (ErrEmptyDoubleQuotes thQuotes) [] span
{-
%************************************************************************
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f6fbe47fe6..6560d5e735 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -197,10 +197,9 @@ getAndRemoveAnnotationComments anns span =
-- various syntactic keywords that are not captured in the existing
-- AST.
--
--- The annotations, together with original source comments are made
--- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.
--- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in
--- @'GHC.Driver.Session.DynFlags'@ before parsing.
+-- The annotations, together with original source comments are made available in
+-- the @'pm_annotations'@ field of @'GHC.Driver.Types.HsParsedModule'@.
+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set.
--
-- The wiki page describing this feature is
-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations
diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs
new file mode 100644
index 0000000000..b67bf32baf
--- /dev/null
+++ b/compiler/GHC/Parser/Errors.hs
@@ -0,0 +1,404 @@
+module GHC.Parser.Errors
+ ( Warning(..)
+ , TransLayoutReason(..)
+ , NumUnderscoreReason(..)
+ , Error(..)
+ , ErrorDesc(..)
+ , LexErr(..)
+ , CmmParserError(..)
+ , LexErrKind(..)
+ , Hint(..)
+ , StarIsType (..)
+ )
+where
+
+import GHC.Prelude
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader (RdrName)
+import GHC.Types.Name.Occurrence (OccName)
+import GHC.Parser.Types
+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.Utils.Outputable (SDoc)
+import GHC.Data.FastString
+import GHC.Unit.Module.Name
+
+data Warning
+
+ -- | Warn when tabulations are found
+ = WarnTab
+ { tabFirst :: !SrcSpan -- ^ First occurence of a tab
+ , tabCount :: !Word -- ^ Number of other occurences
+ }
+
+ | WarnTransitionalLayout !SrcSpan !TransLayoutReason
+ -- ^ Transitional layout warnings
+
+ | WarnUnrecognisedPragma !SrcSpan
+ -- ^ Unrecognised pragma
+
+ | WarnHaddockInvalidPos !SrcSpan
+ -- ^ Invalid Haddock comment position
+
+ | WarnHaddockIgnoreMulti !SrcSpan
+ -- ^ Multiple Haddock comment for the same entity
+
+ | WarnStarBinder !SrcSpan
+ -- ^ Found binding occurence of "*" while StarIsType is enabled
+
+ | WarnStarIsType !SrcSpan
+ -- ^ Using "*" for "Type" without StarIsType enabled
+
+ | WarnImportPreQualified !SrcSpan
+ -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled
+
+
+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 Error = Error
+ { errDesc :: !ErrorDesc -- ^ Error description
+ , errHints :: ![Hint] -- ^ Hints
+ , errLoc :: !SrcSpan -- ^ Error position
+ }
+
+data ErrorDesc
+ = ErrLambdaCase
+ -- ^ LambdaCase syntax used without the extension enabled
+
+ | ErrNumUnderscores !NumUnderscoreReason
+ -- ^ Underscores in literals without the extension enabled
+
+ | ErrPrimStringInvalidChar
+ -- ^ Invalid character in primitive string
+
+ | ErrMissingBlock
+ -- ^ Missing block
+
+ | ErrLexer !LexErr !LexErrKind
+ -- ^ Lexer error
+
+ | ErrSuffixAT
+ -- ^ Suffix occurence of `@`
+
+ | ErrParse !String
+ -- ^ Parse errors
+
+ | ErrCmmLexer
+ -- ^ Cmm lexer error
+
+ | ErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))
+ -- ^ Unsupported boxed sum in expression
+
+ | ErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))
+ -- ^ Unsupported boxed sum in pattern
+
+ | ErrUnexpectedQualifiedConstructor !RdrName
+ -- ^ Unexpected qualified constructor
+
+ | ErrTupleSectionInPat
+ -- ^ Tuple section in pattern context
+
+ | ErrIllegalBangPattern !(Pat GhcPs)
+ -- ^ Bang-pattern without BangPattterns enabled
+
+ | ErrOpFewArgs !StarIsType !RdrName
+ -- ^ Operator applied to too few arguments
+
+ | ErrImportQualifiedTwice
+ -- ^ Import: multiple occurrences of 'qualified'
+
+ | ErrImportPostQualified
+ -- ^ Post qualified import without 'ImportQualifiedPost'
+
+ | ErrIllegalExplicitNamespace
+ -- ^ Explicit namespace keyword without 'ExplicitNamespaces'
+
+ | ErrVarForTyCon !RdrName
+ -- ^ Expecting a type constructor but found a variable
+
+ | ErrIllegalPatSynExport
+ -- ^ Illegal export form allowed by PatternSynonyms
+
+ | ErrMalformedEntityString
+ -- ^ Malformed entity string
+
+ | ErrDotsInRecordUpdate
+ -- ^ Dots used in record update
+
+ | ErrPrecedenceOutOfRange !Int
+ -- ^ Precedence out of range
+
+ | ErrInvalidDataCon !(HsType GhcPs)
+ -- ^ Cannot parse data constructor in a data/newtype declaration
+
+ | ErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)
+ -- ^ Cannot parse data constructor in a data/newtype declaration
+
+ | ErrUnpackDataCon
+ -- ^ UNPACK applied to a data constructor
+
+ | ErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)
+ -- ^ Unexpected kind application in data/newtype declaration
+
+ | ErrInvalidRecordCon !(PatBuilder GhcPs)
+ -- ^ Not a record constructor
+
+ | ErrIllegalUnboxedStringInPat !(HsLit GhcPs)
+ -- ^ Illegal unboxed string literal in pattern
+
+ | ErrDoNotationInPat
+ -- ^ Do-notation in pattern
+
+ | ErrIfTheElseInPat
+ -- ^ If-then-else syntax in pattern
+
+ | ErrTypeAppInPat
+ -- ^ Type-application in pattern
+
+ | ErrLambdaCaseInPat
+ -- ^ Lambda-case in pattern
+
+ | ErrCaseInPat
+ -- ^ case..of in pattern
+
+ | ErrLetInPat
+ -- ^ let-syntax in pattern
+
+ | ErrLambdaInPat
+ -- ^ Lambda-syntax in pattern
+
+ | ErrArrowExprInPat !(HsExpr GhcPs)
+ -- ^ Arrow expression-syntax in pattern
+
+ | ErrArrowCmdInPat !(HsCmd GhcPs)
+ -- ^ Arrow command-syntax in pattern
+
+ | ErrArrowCmdInExpr !(HsCmd GhcPs)
+ -- ^ Arrow command-syntax in expression
+
+ | ErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)
+ -- ^ View-pattern in expression
+
+ | ErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)
+ -- ^ Type-application without space before '@'
+
+ | ErrLazyPatWithoutSpace !(LHsExpr GhcPs)
+ -- ^ Lazy-pattern ('~') without space after it
+
+ | ErrBangPatWithoutSpace !(LHsExpr GhcPs)
+ -- ^ Bang-pattern ('!') without space after it
+
+ | ErrUnallowedPragma !(HsPragE GhcPs)
+ -- ^ Pragma not allowed in this position
+
+ | ErrQualifiedDoInCmd !ModuleName
+ -- ^ Qualified do block in command
+
+ | ErrInvalidInfixHole
+ -- ^ Invalid infix hole, expected an infix operator
+
+ | ErrSemiColonsInCondExpr
+ -- ^ 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
+
+ | ErrSemiColonsInCondCmd
+ -- ^ 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
+
+ | ErrAtInPatPos
+ -- ^ @-operator in a pattern position
+
+ | ErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- ^ Unexpected lambda command in function application
+
+ | ErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- ^ Unexpected case command in function application
+
+ | ErrIfCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- ^ Unexpected if command in function application
+
+ | ErrLetCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- ^ Unexpected let command in function application
+
+ | ErrDoCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- ^ Unexpected do command in function application
+
+ | ErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)
+ -- ^ Unexpected do block in function application
+
+ | ErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)
+ -- ^ Unexpected mdo block in function application
+
+ | ErrLambdaInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected lambda expression in function application
+
+ | ErrCaseInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected case expression in function application
+
+ | ErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected lambda-case expression in function application
+
+ | ErrLetInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected let expression in function application
+
+ | ErrIfInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected if expression in function application
+
+ | ErrProcInFunAppExpr !(LHsExpr GhcPs)
+ -- ^ Unexpected proc expression in function application
+
+ | ErrMalformedTyOrClDecl !(LHsType GhcPs)
+ -- ^ Malformed head of type or class declaration
+
+ | ErrIllegalWhereInDataDecl
+ -- ^ Illegal 'where' keyword in data declaration
+
+ | ErrIllegalDataTypeContext !(LHsContext GhcPs)
+ -- ^ Illegal datatyp context
+
+ | ErrParseErrorOnInput !OccName
+ -- ^ Parse error on input
+
+ | ErrMalformedDecl !SDoc !RdrName
+ -- ^ Malformed ... declaration for ...
+
+ | ErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName
+ -- ^ Unexpected type application in a declaration
+
+ | ErrNotADataCon !RdrName
+ -- ^ Not a data constructor
+
+ | ErrRecordSyntaxInPatSynDecl !(LPat GhcPs)
+ -- ^ Record syntax used in pattern synonym declaration
+
+ | ErrEmptyWhereInPatSynDecl !RdrName
+ -- ^ Empty 'where' clause in pattern-synonym declaration
+
+ | ErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)
+ -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration
+
+ | ErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)
+ -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration
+
+ | ErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)
+ -- ^ Declaration splice not a top-level
+
+ | ErrInferredTypeVarNotAllowed
+ -- ^ Inferred type variables not allowed here
+
+ | ErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]
+ -- ^ Multiple names in standalone kind signatures
+
+ | ErrIllegalImportBundleForm
+ -- ^ Illegal import bundle form
+
+ | ErrIllegalRoleName !FastString [Role]
+ -- ^ Illegal role name
+
+ | ErrInvalidTypeSignature !(LHsExpr GhcPs)
+ -- ^ Invalid type signature
+
+ | ErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc
+ -- ^ Unexpected type in declaration
+
+ | ErrExpectedHyphen
+ -- ^ Expected a hyphen
+
+ | ErrSpaceInSCC
+ -- ^ Found a space in a SCC
+
+ | ErrEmptyDoubleQuotes !Bool-- Is TH on?
+ -- ^ Found two single quotes
+
+ | ErrInvalidPackageName !FastString
+ -- ^ Invalid package name
+
+ | ErrInvalidRuleActivationMarker
+ -- ^ Invalid rule activation marker
+
+ | ErrLinearFunction
+ -- ^ Linear function found but LinearTypes not enabled
+
+ | ErrMultiWayIf
+ -- ^ Multi-way if-expression found but MultiWayIf not enabled
+
+ | ErrExplicitForall !Bool -- is Unicode forall?
+ -- ^ Explicit forall found but no extension allowing it is enabled
+
+ | ErrIllegalQualifiedDo !SDoc
+ -- ^ Found qualified-do without QualifiedDo enabled
+
+ | ErrCmmParser !CmmParserError
+ -- ^ Cmm parser error
+
+ | ErrIllegalTraditionalRecordSyntax !SDoc
+ -- ^ Illegal traditional record syntax
+ --
+ -- TODO: distinguish errors without using SDoc
+
+ | ErrParseErrorInCmd !SDoc
+ -- ^ Parse error in command
+ --
+ -- TODO: distinguish errors without using SDoc
+
+ | ErrParseErrorInPat !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 Hint
+ = SuggestTH
+ | SuggestRecursiveDo
+ | SuggestDo
+ | SuggestMissingDo
+ | SuggestLetInDo
+ | SuggestPatternSynonyms
+ | SuggestInfixBindMaybeAtPat !RdrName
+
+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
new file mode 100644
index 0000000000..f99cac90a4
--- /dev/null
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -0,0 +1,585 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module GHC.Parser.Errors.Ppr
+ ( pprWarning
+ , pprError
+ )
+where
+
+import GHC.Prelude
+import GHC.Driver.Flags
+import GHC.Parser.Errors
+import GHC.Parser.Types
+import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)
+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)
+import GHC.Utils.Error
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
+import GHC.Data.FastString
+import GHC.Hs.Expr (prependQualified,HsExpr(..))
+import GHC.Hs.Type (pprLHsContext)
+import GHC.Builtin.Names (allNameStrings)
+import GHC.Builtin.Types (filterCTuple)
+
+mkParserErr :: SrcSpan -> SDoc -> ErrMsg
+mkParserErr span doc = ErrMsg
+ { errMsgSpan = span
+ , errMsgContext = alwaysQualify
+ , errMsgDoc = ErrDoc [doc] [] []
+ , errMsgShortString = renderWithContext defaultSDocContext doc
+ , errMsgSeverity = SevError
+ , errMsgReason = NoReason
+ }
+
+mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg
+mkParserWarn flag span doc = ErrMsg
+ { errMsgSpan = span
+ , errMsgContext = alwaysQualify
+ , errMsgDoc = ErrDoc [doc] [] []
+ , errMsgShortString = renderWithContext defaultSDocContext doc
+ , errMsgSeverity = SevWarning
+ , errMsgReason = Reason flag
+ }
+
+pprWarning :: Warning -> ErrMsg
+pprWarning = \case
+ WarnTab loc tc
+ -> mkParserWarn 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."
+
+ WarnTransitionalLayout loc reason
+ -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $
+ 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"
+ )
+
+ WarnUnrecognisedPragma loc
+ -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $
+ text "Unrecognised pragma"
+
+ WarnHaddockInvalidPos loc
+ -> mkParserWarn Opt_WarnInvalidHaddock loc $
+ text "A Haddock comment cannot appear in this position and will be ignored."
+
+ WarnHaddockIgnoreMulti loc
+ -> mkParserWarn Opt_WarnInvalidHaddock loc $
+ text "Multiple Haddock comments for a single entity are not allowed." $$
+ text "The extraneous comment will be ignored."
+
+ WarnStarBinder loc
+ -> mkParserWarn 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."
+
+ WarnStarIsType loc
+ -> mkParserWarn 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."
+
+ WarnImportPreQualified loc
+ -> mkParserWarn 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'"
+
+pprError :: Error -> ErrMsg
+pprError err = mkParserErr (errLoc err) $ vcat
+ (pp_err (errDesc err) : map pp_hint (errHints err))
+
+pp_err :: ErrorDesc -> SDoc
+pp_err = \case
+ ErrLambdaCase
+ -> text "Illegal lambda-case (use LambdaCase)"
+
+ ErrNumUnderscores 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"
+
+ ErrPrimStringInvalidChar
+ -> text "primitive string literal must contain only characters <= \'\\xFF\'"
+
+ ErrMissingBlock
+ -> text "Missing block"
+
+ ErrLexer 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
+ ]
+
+ ErrSuffixAT
+ -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
+
+ ErrParse token
+ | null token
+ -> text "parse error (possibly incorrect indentation or mismatched brackets)"
+
+ | otherwise
+ -> text "parse error on input" <+> quotes (text token)
+
+ ErrCmmLexer
+ -> text "Cmm lexical error"
+
+ ErrUnsupportedBoxedSumExpr s
+ -> hang (text "Boxed sums not supported:") 2
+ (pprSumOrTuple Boxed s)
+
+ ErrUnsupportedBoxedSumPat s
+ -> hang (text "Boxed sums not supported:") 2
+ (pprSumOrTuple Boxed s)
+
+ ErrUnexpectedQualifiedConstructor v
+ -> hang (text "Expected an unqualified type constructor:") 2
+ (ppr v)
+
+ ErrTupleSectionInPat
+ -> text "Tuple section in pattern context"
+
+ ErrIllegalBangPattern e
+ -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e
+
+ ErrOpFewArgs (StarIsType star_is_type) op
+ -> text "Operator applied to too few arguments:" <+> ppr op
+ $$ starInfo star_is_type op
+
+ ErrImportQualifiedTwice
+ -> text "Multiple occurrences of 'qualified'"
+
+ ErrImportPostQualified
+ -> text "Found" <+> quotes (text "qualified")
+ <+> text "in postpositive position. "
+ $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+
+ ErrIllegalExplicitNamespace
+ -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
+
+ ErrVarForTyCon 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
+
+ ErrIllegalPatSynExport
+ -> text "Illegal export form (use PatternSynonyms to enable)"
+
+ ErrMalformedEntityString
+ -> text "Malformed entity string"
+
+ ErrDotsInRecordUpdate
+ -> text "You cannot use `..' in a record update"
+
+ ErrPrecedenceOutOfRange i
+ -> text "Precedence out of range: " <> int i
+
+ ErrInvalidDataCon t
+ -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2
+ (ppr t)
+
+ ErrInvalidInfixDataCon lhs tc rhs
+ -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
+ 2 (ppr lhs <+> ppr tc <+> ppr rhs)
+
+ ErrUnpackDataCon
+ -> text "{-# UNPACK #-} cannot be applied to a data constructor."
+
+ ErrUnexpectedKindAppInDataCon lhs ki
+ -> hang (text "Unexpected kind application in a data/newtype declaration:") 2
+ (ppr lhs <+> text "@" <> ppr ki)
+
+ ErrInvalidRecordCon p
+ -> text "Not a record constructor:" <+> ppr p
+
+ ErrIllegalUnboxedStringInPat lit
+ -> text "Illegal unboxed string literal in pattern:" $$ ppr lit
+
+ ErrDoNotationInPat
+ -> text "do-notation in pattern"
+
+ ErrIfTheElseInPat
+ -> text "(if ... then ... else ...)-syntax in pattern"
+
+ ErrTypeAppInPat
+ -> text "Type applications in patterns are not yet supported"
+
+ ErrLambdaCaseInPat
+ -> text "(\\case ...)-syntax in pattern"
+
+ ErrCaseInPat
+ -> text "(case ... of ...)-syntax in pattern"
+
+ ErrLetInPat
+ -> text "(let ... in ...)-syntax in pattern"
+
+ ErrLambdaInPat
+ -> text "Lambda-syntax in pattern."
+ $$ text "Pattern matching on functions is not possible."
+
+ ErrArrowExprInPat e
+ -> text "Expression syntax in pattern:" <+> ppr e
+
+ ErrArrowCmdInPat c
+ -> text "Command syntax in pattern:" <+> ppr c
+
+ ErrArrowCmdInExpr c
+ -> vcat
+ [ text "Arrow command found where an expression was expected:"
+ , nest 2 (ppr c)
+ ]
+
+ ErrViewPatInExpr a b
+ -> sep [ text "View pattern in expression context:"
+ , nest 4 (ppr a <+> text "->" <+> ppr b)
+ ]
+
+ ErrTypeAppWithoutSpace v e
+ -> sep [ text "@-pattern in expression context:"
+ , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)
+ ]
+ $$ text "Type application syntax requires a space before '@'"
+
+
+ ErrLazyPatWithoutSpace e
+ -> sep [ text "Lazy pattern in expression context:"
+ , nest 4 (text "~" <> ppr e)
+ ]
+ $$ text "Did you mean to add a space after the '~'?"
+
+ ErrBangPatWithoutSpace e
+ -> sep [ text "Bang pattern in expression context:"
+ , nest 4 (text "!" <> ppr e)
+ ]
+ $$ text "Did you mean to add a space after the '!'?"
+
+ ErrUnallowedPragma prag
+ -> hang (text "A pragma is not allowed in this position:") 2
+ (ppr prag)
+
+ ErrQualifiedDoInCmd 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."
+
+ ErrParseErrorInCmd s
+ -> hang (text "Parse error in command:") 2 s
+
+ ErrParseErrorInPat s
+ -> text "Parse error in pattern:" <+> s
+
+
+ ErrInvalidInfixHole
+ -> text "Invalid infix hole, expected an infix operator"
+
+ ErrSemiColonsInCondExpr c st t se e
+ -> 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
+
+ ErrSemiColonsInCondCmd c st t se e
+ -> 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
+
+
+ ErrAtInPatPos
+ -> text "Found a binding for the"
+ <+> quotes (text "@")
+ <+> text "operator in a pattern position."
+ $$ perhaps_as_pat
+
+ ErrLambdaCmdInFunAppCmd a
+ -> pp_unexpected_fun_app (text "lambda command") a
+
+ ErrCaseCmdInFunAppCmd a
+ -> pp_unexpected_fun_app (text "case command") a
+
+ ErrIfCmdInFunAppCmd a
+ -> pp_unexpected_fun_app (text "if command") a
+
+ ErrLetCmdInFunAppCmd a
+ -> pp_unexpected_fun_app (text "let command") a
+
+ ErrDoCmdInFunAppCmd a
+ -> pp_unexpected_fun_app (text "do command") a
+
+ ErrDoInFunAppExpr m a
+ -> pp_unexpected_fun_app (prependQualified m (text "do block")) a
+
+ ErrMDoInFunAppExpr m a
+ -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a
+
+ ErrLambdaInFunAppExpr a
+ -> pp_unexpected_fun_app (text "lambda expression") a
+
+ ErrCaseInFunAppExpr a
+ -> pp_unexpected_fun_app (text "case expression") a
+
+ ErrLambdaCaseInFunAppExpr a
+ -> pp_unexpected_fun_app (text "lambda-case expression") a
+
+ ErrLetInFunAppExpr a
+ -> pp_unexpected_fun_app (text "let expression") a
+
+ ErrIfInFunAppExpr a
+ -> pp_unexpected_fun_app (text "if expression") a
+
+ ErrProcInFunAppExpr a
+ -> pp_unexpected_fun_app (text "proc expression") a
+
+ ErrMalformedTyOrClDecl ty
+ -> text "Malformed head of type or class declaration:"
+ <+> ppr ty
+
+ ErrIllegalWhereInDataDecl
+ -> 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"
+ ]
+
+ ErrIllegalTraditionalRecordSyntax s
+ -> text "Illegal record syntax (use TraditionalRecordSyntax):"
+ <+> s
+
+ ErrParseErrorOnInput occ
+ -> text "parse error on input" <+> ftext (occNameFS occ)
+
+ ErrIllegalDataTypeContext c
+ -> text "Illegal datatype context (use DatatypeContexts):"
+ <+> pprLHsContext c
+
+ ErrMalformedDecl what for
+ -> text "Malformed" <+> what
+ <+> text "declaration for" <+> quotes (ppr for)
+
+ ErrUnexpectedTypeAppInDecl ki what for
+ -> vcat [ text "Unexpected type application"
+ <+> text "@" <> ppr ki
+ , text "In the" <+> what
+ <+> text "declaration for"
+ <+> quotes (ppr for)
+ ]
+
+ ErrNotADataCon name
+ -> text "Not a data constructor:" <+> quotes (ppr name)
+
+ ErrRecordSyntaxInPatSynDecl pat
+ -> text "record syntax not supported for pattern synonym declarations:"
+ $$ ppr pat
+
+ ErrEmptyWhereInPatSynDecl patsyn_name
+ -> text "pattern synonym 'where' clause cannot be empty"
+ $$ text "In the pattern synonym declaration for: "
+ <+> ppr (patsyn_name)
+
+ ErrInvalidWhereBindInPatSynDecl patsyn_name decl
+ -> text "pattern synonym 'where' clause must bind the pattern synonym's name"
+ <+> quotes (ppr patsyn_name) $$ ppr decl
+
+ ErrNoSingleWhereBindInPatSynDecl _patsyn_name decl
+ -> text "pattern synonym 'where' clause must contain a single binding:"
+ $$ ppr decl
+
+ ErrDeclSpliceNotAtTopLevel d
+ -> hang (text "Declaration splices are allowed only"
+ <+> text "at the top level:")
+ 2 (ppr d)
+
+ ErrInferredTypeVarNotAllowed
+ -> text "Inferred type variables are not allowed here"
+
+ ErrIllegalRoleName 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)
+
+ ErrMultipleNamesInStandaloneKindSignature 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."
+ ]
+
+ ErrIllegalImportBundleForm
+ -> text "Illegal import form, this syntax can only be used to bundle"
+ $+$ text "pattern synonyms with types in module exports."
+
+ ErrInvalidTypeSignature lhs
+ -> text "Invalid type signature:"
+ <+> ppr lhs
+ <+> text ":: ..."
+ $$ text hint
+ where
+ hint | foreign_RDR `looks_like` lhs
+ = "Perhaps you meant to use ForeignFunctionInterface?"
+ | default_RDR `looks_like` lhs
+ = "Perhaps you meant to use DefaultSignatures?"
+ | pattern_RDR `looks_like` lhs
+ = "Perhaps you meant to use PatternSynonyms?"
+ | otherwise
+ = "Should be of form <variable> :: <type>"
+
+ -- A common error is to forget the ForeignFunctionInterface flag
+ -- so check for that, and suggest. cf #3805
+ -- Sadly 'foreign import' still barfs 'parse error' because
+ -- 'import' is a keyword
+ looks_like s (L _ (HsVar _ (L _ v))) = v == s
+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
+ looks_like _ _ = False
+
+ foreign_RDR = mkUnqual varName (fsLit "foreign")
+ default_RDR = mkUnqual varName (fsLit "default")
+ pattern_RDR = mkUnqual varName (fsLit "pattern")
+
+ ErrUnexpectedTypeInDecl t what tc tparms equals_or_where
+ -> vcat [ text "Unexpected type" <+> quotes (ppr t)
+ , text "In the" <+> what
+ <+> ptext (sLit "declaration for") <+> quotes tc'
+ , vcat[ (text "A" <+> what
+ <+> ptext (sLit "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
+
+ ErrCmmParser 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
+
+ ErrExpectedHyphen
+ -> text "Expected a hyphen"
+
+ ErrSpaceInSCC
+ -> text "Spaces are not allowed in SCCs"
+
+ ErrEmptyDoubleQuotes 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"
+ ]
+
+ ErrInvalidPackageName pkg
+ -> vcat
+ [ text "Parse error" <> colon <+> quotes (ftext pkg)
+ , text "Version number or non-alphanumeric" <+>
+ text "character in package name"
+ ]
+
+ ErrInvalidRuleActivationMarker
+ -> text "Invalid rule activation marker"
+
+ ErrLinearFunction
+ -> text "Enable LinearTypes to allow linear functions"
+
+ ErrMultiWayIf
+ -> text "Multi-way if-expressions need MultiWayIf turned on"
+
+ ErrExplicitForall 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"
+
+ ErrIllegalQualifiedDo qdoDoc
+ -> vcat
+ [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
+ , text "Perhaps you intended to use QualifiedDo"
+ ]
+
+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?"
+
+pp_hint :: Hint -> SDoc
+pp_hint = \case
+ SuggestTH -> text "Perhaps you intended to use TemplateHaskell"
+ SuggestDo -> text "Perhaps this statement should be within a 'do' block?"
+ SuggestMissingDo -> text "Possibly caused by a missing 'do'?"
+ SuggestRecursiveDo -> text "Perhaps you intended to use RecursiveDo"
+ SuggestLetInDo -> text "Perhaps you need a 'let' in a 'do' block?"
+ $$ text "e.g. 'let x = 5' instead of 'x = 5'"
+ SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"
+
+ SuggestInfixBindMaybeAtPat fun
+ -> text "In a function binding for the"
+ <+> quotes (ppr fun)
+ <+> text "operator."
+ $$ if opIsAt fun
+ then perhaps_as_pat
+ else empty
+
+perhaps_as_pat :: SDoc
+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
+
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 64b1ee8333..f63e44f3c4 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -27,6 +27,8 @@ where
import GHC.Prelude
import GHC.Platform
+import GHC.Parser.Errors.Ppr
+import GHC.Parser.Errors
import GHC.Driver.Types
import GHC.Parser ( parseHeader )
import GHC.Parser.Lexer
@@ -43,7 +45,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe
-import GHC.Data.Bag ( emptyBag, listToBag, unitBag )
+import GHC.Data.Bag ( Bag, emptyBag, listToBag, unitBag, isEmptyBag )
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
import GHC.Types.Basic
@@ -66,7 +68,7 @@ getImports :: DynFlags
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
-> IO (Either
- ErrorMessages
+ (Bag Error)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)],
Located ModuleName))
@@ -77,15 +79,13 @@ getImports dflags buf filename source_filename = do
case unP parseHeader (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
-- assuming we're not logging warnings here as per below
- return $ Left $ getErrorMessages pst dflags
+ return $ Left $ getErrorMessages pst
POk pst rdr_module -> fmap Right $ do
- let _ms@(_warns, errs) = getMessages pst dflags
+ let (_warns, errs) = getMessages pst
-- don't log warnings: they'll be reported when we parse the file
-- for real. See #2500.
- ms = (emptyBag, errs)
- -- logWarnings warns
- if errorsFound dflags ms
- then throwIO $ mkSrcErr errs
+ if not (isEmptyBag errs)
+ then throwIO $ mkSrcErr (fmap pprError 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 b3d83b2408..90ee473c5d 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -53,8 +53,6 @@ module GHC.Parser.Lexer (
ParserOpts(..), mkParserOpts,
PState (..), initParserState, initPragState,
P(..), ParseResult(..),
- appendWarning,
- appendError,
allocateComments,
MonadP(..),
getRealSrcLoc, getPState, withHomeUnitId,
@@ -70,6 +68,7 @@ module GHC.Parser.Lexer (
addAnnsAt,
commentToAnnotation,
HdkComment(..),
+ warnopt,
) where
import GHC.Prelude
@@ -104,8 +103,6 @@ import GHC.Types.Unique.FM
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Utils.Misc ( readRational, readHexRational )
-import GHC.Utils.Error
-import GHC.Driver.Session as DynFlags
import GHC.Types.SrcLoc
import GHC.Unit
@@ -117,6 +114,8 @@ import GHC.Hs.Doc
import GHC.Parser.CharClass
import GHC.Parser.Annotation
+import GHC.Driver.Flags
+import GHC.Parser.Errors
}
-- -----------------------------------------------------------------------------
@@ -357,7 +356,7 @@ $tab { warnTab }
}
<0,option_prags> {
- "{-#" { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
+ "{-#" { warnThen Opt_WarnUnrecognisedPragmas WarnUnrecognisedPragma
(nested_comment lexToken) }
}
@@ -1086,7 +1085,7 @@ failLinePrag1 :: Action
failLinePrag1 span _buf _len = do
b <- getBit InNestedCommentBit
if b then return (L span ITcomment_line_prag)
- else lexError "lexical error in pragma"
+ else lexError LexErrorInPragma
-- See Note [Nested comment line pragmas]
popLinePrag1 :: Action
@@ -1107,7 +1106,7 @@ 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 (mkSrcSpanPs span) (text "Missing block")
+ else addFatalError $ Error ErrMissingBlock [] (mkSrcSpanPs span)
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
@@ -1486,7 +1485,7 @@ 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) "unterminated `{-'"
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (Error (ErrLexer LexUnterminatedComment LexErrKind_EOF) [])
open_brace, close_brace :: Action
open_brace span _str _len = do
@@ -1545,8 +1544,7 @@ varid span buf len =
lambdaCase <- getBit LambdaCaseBit
unless lambdaCase $ do
pState <- getPState
- addError (mkSrcSpanPs (last_loc pState)) $ text
- "Illegal lambda-case (use LambdaCase)"
+ addError $ Error ErrLambdaCase [] (mkSrcSpanPs (last_loc pState))
return ITlcase
_ -> return ITcase
maybe_layout keyword
@@ -1595,9 +1593,8 @@ varsym_prefix = sym $ \exts s ->
-- See Note [Whitespace-sensitive operator parsing]
varsym_suffix :: Action
varsym_suffix = sym $ \_ s ->
- if | s == fsLit "@"
- -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
- | otherwise -> return (ITvarsym s)
+ if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT [])
+ | otherwise -> return (ITvarsym s)
-- See Note [Whitespace-sensitive operator parsing]
varsym_tight_infix :: Action
@@ -1649,8 +1646,7 @@ 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 (mkSrcSpanPs (last_loc pState)) $ text
- "Use NumericUnderscores to allow underscores in integer literals"
+ addError $ Error (ErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))
return $ L span $ itint (SourceText src)
$! transint $ parseUnsignedInteger
(offsetBytes transbuf buf) (subtract translen len) radix char_to_int
@@ -1691,8 +1687,7 @@ tok_frac drop f span buf len = do
let src = lexemeToString buf (len-drop)
when ((not numericUnderscores) && ('_' `elem` src)) $ do
pState <- getPState
- addError (mkSrcSpanPs (last_loc pState)) $ text
- "Use NumericUnderscores to allow underscores in floating literals"
+ addError $ Error (ErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))
return (L span $! (f $! src))
tok_float, tok_primfloat, tok_primdouble :: String -> Token
@@ -1862,7 +1857,7 @@ lex_string_prag 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) "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (Error (ErrLexer LexUnterminatedOptions LexErrKind_EOF) [])
-- -----------------------------------------------------------------------------
@@ -1900,8 +1895,8 @@ lex_string s = do
setInput i
when (any (> '\xFF') s') $ do
pState <- getPState
- addError (mkSrcSpanPs (last_loc pState)) $ text
- "primitive string literal must contain only characters <= \'\\xFF\'"
+ let err = Error ErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))
+ addError err
return (ITprimstring (SourceText s') (unsafeMkByteString s'))
_other ->
return (ITstring (SourceText s') (mkFastString s'))
@@ -2057,7 +2052,7 @@ readNum2 is_digit base conv i = do
Just (c,input') | is_digit c -> do
let i' = i*base + conv c
if i' > 0x10ffff
- then setInput input >> lexError "numeric escape sequence out of range"
+ then setInput input >> lexError LexNumEscapeRange
else read i' input'
_other -> do
setInput input; return (chr i)
@@ -2106,12 +2101,12 @@ silly_escape_chars = [
-- a correct location to the user, but also so we can detect UTF-8 decoding
-- errors if they occur.
lit_error :: AlexInput -> P a
-lit_error i = do setInput i; lexError "lexical error in string/character literal"
+lit_error i = do setInput i; lexError LexStringCharLit
getCharOrFail :: AlexInput -> P Char
getCharOrFail i = do
case alexGetChar' i of
- Nothing -> lexError "unexpected end-of-file in string/character literal"
+ Nothing -> lexError LexStringCharLitEOF
Just (c,i) -> do setInput i; return c
-- -----------------------------------------------------------------------------
@@ -2162,7 +2157,8 @@ lex_quasiquote start s = do
quasiquote_error :: RealSrcLoc -> P a
quasiquote_error start = do
(AI end buf) <- getInput
- reportLexError start (psRealLoc end) buf "unterminated quasiquotation"
+ reportLexError start (psRealLoc end) buf
+ (\k -> Error (ErrLexer LexUnterminatedQQ k) [])
-- -----------------------------------------------------------------------------
-- Warnings
@@ -2172,9 +2168,9 @@ warnTab srcspan _buf _len = do
addTabWarning (psRealSpan srcspan)
lexToken
-warnThen :: WarningFlag -> SDoc -> Action -> Action
-warnThen option warning action srcspan buf len = do
- addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning
+warnThen :: WarningFlag -> (SrcSpan -> Warning) -> Action -> Action
+warnThen flag warning action srcspan buf len = do
+ addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))
action srcspan buf len
-- -----------------------------------------------------------------------------
@@ -2234,11 +2230,10 @@ data HdkComment
data PState = PState {
buffer :: StringBuffer,
options :: ParserOpts,
- -- This needs to take DynFlags as an argument until
- -- we have a fix for #10143
- messages :: DynFlags -> Messages,
+ warnings :: Bag Warning,
+ errors :: Bag Error,
tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file
- tab_count :: !Int, -- number of tab warnings in the file
+ tab_count :: !Word, -- number of tab warnings in the file
last_tk :: Maybe Token,
last_loc :: PsSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
@@ -2316,14 +2311,14 @@ thenP :: P a -> (a -> P b) -> P b
POk s1 a -> (unP (k a)) s1
PFailed s1 -> PFailed s1
-failMsgP :: String -> P a
-failMsgP msg = do
+failMsgP :: (SrcSpan -> Error) -> P a
+failMsgP f = do
pState <- getPState
- addFatalError (mkSrcSpanPs (last_loc pState)) (text msg)
+ addFatalError (f (mkSrcSpanPs (last_loc pState)))
-failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str =
- addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str)
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> Error) -> P a
+failLocMsgP loc1 loc2 f =
+ addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))
getPState :: P PState
getPState = P $ \s -> POk s s
@@ -2370,7 +2365,7 @@ setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
getLastTk :: P (Maybe Token)
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
-data AlexInput = AI PsLoc StringBuffer
+data AlexInput = AI !PsLoc !StringBuffer
{-
Note [Unicode in Alex]
@@ -2732,7 +2727,8 @@ initParserState options buf loc =
PState {
buffer = buf,
options = options,
- messages = const emptyMessages,
+ errors = emptyBag,
+ warnings = emptyBag,
tab_first = Nothing,
tab_count = 0,
last_tk = Nothing,
@@ -2778,59 +2774,40 @@ 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 :: SrcSpan -> SDoc -> m ()
+ addError :: Error -> m ()
+
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
- addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()
+ addWarning :: WarningFlag -> Warning -> 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 :: SrcSpan -> SDoc -> m a
+ addFatalError :: Error -> m a
+
-- | Check if a given flag is currently set in the bitmap.
getBit :: ExtBits -> m Bool
+
-- | Given a location and a list of AddAnn, apply them all to the location.
addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
-> AnnKeywordId -- The first two parameters are the key
-> SrcSpan -- The location of the keyword itself
-> m ()
-appendError
- :: SrcSpan
- -> SDoc
- -> (DynFlags -> Messages)
- -> (DynFlags -> Messages)
-appendError srcspan msg m =
- \d ->
- let (ws, es) = m d
- errormsg = mkErrMsg d srcspan alwaysQualify msg
- es' = es `snocBag` errormsg
- in (ws, es')
-
-appendWarning
- :: ParserOpts
- -> WarningFlag
- -> SrcSpan
- -> SDoc
- -> (DynFlags -> Messages)
- -> (DynFlags -> Messages)
-appendWarning o option srcspan warning m =
- \d ->
- let (ws, es) = m d
- warning' = makeIntoWarning (Reason option) $
- mkWarnMsg d srcspan alwaysQualify warning
- ws' = if warnopt option o then ws `snocBag` warning' else ws
- in (ws', es)
-
instance MonadP P where
- addError srcspan msg
- = P $ \s@PState{messages=m} ->
- POk s{messages=appendError srcspan msg m} ()
- addWarning option srcspan warning
- = P $ \s@PState{messages=m, options=o} ->
- POk s{messages=appendWarning o option srcspan warning m} ()
- addFatalError span msg =
- addError span msg >> P PFailed
+ addError err
+ = P $ \s -> POk s { errors = err `consBag` errors s} ()
+
+ addWarning option w
+ = P $ \s -> if warnopt option (options s)
+ then POk (s { warnings = w `consBag` warnings s }) ()
+ else POk s ()
+
+ addFatalError err =
+ addError err >> P PFailed
+
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
+
addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do
addAnnotationOnly l a v
allocateCommentsP l
@@ -2849,32 +2826,23 @@ addTabWarning srcspan
else s
in POk s' ()
-mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
-mkTabWarning PState{tab_first=tf, tab_count=tc} d =
- let middle = if tc == 1
- then text ""
- else text ", and in" <+> speakNOf (tc - 1) (text "further location")
- message = text "Tab character found here"
- <> middle
- <> text "."
- $+$ text "Please use spaces instead."
- in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
- mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf
-
-- | Get a bag of the errors that have been accumulated so far.
-- Does not take -Werror into account.
-getErrorMessages :: PState -> DynFlags -> ErrorMessages
-getErrorMessages PState{messages=m} d =
- let (_, es) = m d in es
+getErrorMessages :: PState -> Bag Error
+getErrorMessages p = errors p
-- | Get the warnings and errors accumulated so far.
-- Does not take -Werror into account.
-getMessages :: PState -> DynFlags -> Messages
-getMessages p@PState{messages=m} d =
- let (ws, es) = m d
- tabwarning = mkTabWarning p d
- ws' = maybe ws (`consBag` ws) tabwarning
- in (ws', es)
+getMessages :: PState -> (Bag Warning, Bag Error)
+getMessages p =
+ let ws = warnings p
+ -- we add the tabulation warning on the fly because
+ -- we count the number of occurences of tab characters
+ ws' = case tab_first p of
+ Nothing -> ws
+ Just tf -> WarnTab (RealSrcSpan tf Nothing) (tab_count p)
+ `consBag` ws
+ in (ws', errors p)
getContext :: P [LayoutContext]
getContext = P $ \s@PState{context=ctx} -> POk s ctx
@@ -2889,7 +2857,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
(_:tl) ->
POk s{ context = tl } ()
[] ->
- unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
+ unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
-- Push a new layout context at the indentation of the last token read.
pushCurrentContext :: GenSemic -> P ()
@@ -2919,29 +2887,27 @@ srcParseErr
:: ParserOpts
-> StringBuffer -- current buffer (placed just after the last token)
-> Int -- length of the previous token
- -> MsgDoc
-srcParseErr options buf len
- = if null token
- then text "parse error (possibly incorrect indentation or mismatched brackets)"
- else text "parse error on input" <+> quotes (text token)
- $$ ppWhen (not th_enabled && token == "$") -- #7396
- (text "Perhaps you intended to use TemplateHaskell")
- $$ ppWhen (token == "<-")
- (if mdoInLast100
- then text "Perhaps you intended to use RecursiveDo"
- else text "Perhaps this statement should be within a 'do' block?")
- $$ ppWhen (token == "=" && doInLast100) -- #15849
- (text "Perhaps you need a 'let' in a 'do' block?"
- $$ text "e.g. 'let x = 5' instead of 'x = 5'")
- $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
- (text "Perhaps you intended to use PatternSynonyms")
- where token = lexemeToString (offsetBytes (-len) buf) len
- pattern = decodePrevNChars 8 buf
- last100 = decodePrevNChars 100 buf
- doInLast100 = "do" `isInfixOf` last100
- mdoInLast100 = "mdo" `isInfixOf` last100
- th_enabled = ThQuotesBit `xtest` pExtsBitmap options
- ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
+ -> SrcSpan
+ -> Error
+srcParseErr options buf len loc = Error (ErrParse token) suggests loc
+ where
+ token = lexemeToString (offsetBytes (-len) buf) len
+ pattern = decodePrevNChars 8 buf
+ last100 = decodePrevNChars 100 buf
+ doInLast100 = "do" `isInfixOf` last100
+ 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 == "$") SuggestTH -- #7396
+ sug_rdo = sug (token == "<-" && mdoInLast100) SuggestRecursiveDo
+ sug_do = sug (token == "<-" && not mdoInLast100) SuggestDo
+ sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849
+ sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429
+ suggests
+ | null token = []
+ | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]
-- Report a parse failure, giving the span of the previous token as
-- the location of the error. This is the entry point for errors
@@ -2949,15 +2915,16 @@ srcParseErr options buf len
srcParseFail :: P a
srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
last_loc = last_loc } ->
- unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
+ unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
-lexError :: String -> P a
-lexError str = do
+lexError :: LexErr -> P a
+lexError e = do
loc <- getRealSrcLoc
(AI end buf) <- getInput
- reportLexError loc (psRealLoc end) buf str
+ reportLexError loc (psRealLoc end) buf
+ (\k -> Error (ErrLexer e k) [])
-- -----------------------------------------------------------------------------
-- This is the top-level function: called from the parser each time a
@@ -3073,9 +3040,7 @@ alternativeLayoutRuleToken t
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- (mkSrcSpanPs thisLoc)
- (transitionalAlternativeLayoutWarning
- "`where' clause at the same depth as implicit layout block")
+ $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where
setALRContext ls
setNextToken t
-- Note that we use lastLoc, as we may need to close
@@ -3085,9 +3050,7 @@ alternativeLayoutRuleToken t
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- (mkSrcSpanPs thisLoc)
- (transitionalAlternativeLayoutWarning
- "`|' at the same depth as implicit layout block")
+ $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe
setALRContext ls
setNextToken t
-- Note that we use lastLoc, as we may need to close
@@ -3154,11 +3117,6 @@ alternativeLayoutRuleToken t
-- the other ITwhere case omitted; general case below covers it
(_, _, _) -> return t
-transitionalAlternativeLayoutWarning :: String -> SDoc
-transitionalAlternativeLayoutWarning msg
- = text "transitional layout will not be accepted in the future:"
- $$ text msg
-
isALRopen :: Token -> Bool
isALRopen ITcase = True
isALRopen ITif = True
@@ -3213,7 +3171,8 @@ lexToken = do
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
- reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error"
+ reportLexError (psRealLoc loc1) (psRealLoc loc2) buf
+ (\k -> Error (ErrLexer LexError k) [])
AlexSkip inp2 _ -> do
setInput inp2
lexToken
@@ -3227,14 +3186,14 @@ lexToken = do
unless (isComment lt') (setLastTk lt')
return lt
-reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
-reportLexError loc1 loc2 buf str
- | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> Error) -> P a
+reportLexError loc1 loc2 buf f
+ | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)
| otherwise =
let c = fst (nextChar buf)
in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
- then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
- else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
+ then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)
+ else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))
lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream opts buf loc = unP go initState{ options = opts' }
@@ -3309,7 +3268,7 @@ twoWordPrags = Map.fromList [
dispatch_pragmas :: Map String Action -> Action
dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
Just found -> found span buf len
- Nothing -> lexError "unknown pragma"
+ Nothing -> lexError LexUnknownPragma
known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 48bcc45091..648ab1bfa4 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -35,7 +35,6 @@ module GHC.Parser.PostProcess (
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
- filterCTuple,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
cvBindGroup,
@@ -58,7 +57,7 @@ module GHC.Parser.PostProcess (
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
- checkPattern_msg,
+ checkPattern_hints,
checkMonadComp, -- P (HsStmtContext GhcPs)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -81,7 +80,6 @@ module GHC.Parser.PostProcess (
checkImportSpec,
-- Token symbols
- forallSym,
starSym,
-- Warnings and errors
@@ -106,7 +104,6 @@ module GHC.Parser.PostProcess (
-- Type/datacon ambiguity resolution
DisambTD(..),
addUnpackednessP,
- DataConBuilder(),
dataConBuilderCon,
dataConBuilderDetails,
) where
@@ -121,27 +118,27 @@ import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
+import GHC.Parser.Types
import GHC.Parser.Lexer
+import GHC.Parser.Errors
import GHC.Utils.Lexeme ( isLexCon )
import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
- listTyConName, listTyConKey, eqTyCon_RDR,
- tupleTyConName, cTupleTyConNameArity_maybe )
+ listTyConName, listTyConKey, eqTyCon_RDR )
import GHC.Types.ForeignCall
-import GHC.Builtin.Names ( allNameStrings )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
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.Misc
import GHC.Parser.Annotation
import Data.List
import Data.Foldable
-import GHC.Driver.Session ( WarningFlag(..), DynFlags )
-import GHC.Utils.Error ( Messages )
+import GHC.Driver.Session ( WarningFlag(..) )
import GHC.Utils.Panic
import Control.Monad
@@ -264,16 +261,12 @@ mkStandaloneKindSig loc lhs rhs =
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
then return v
- else addFatalError (getLoc v) $
- hang (text "Expected an unqualified type constructor:") 2 (ppr v)
+ else addFatalError $ Error (ErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v)
check_singular_lhs vs =
case vs of
[] -> panic "mkStandaloneKindSig: empty left-hand side"
[v] -> return v
- _ -> addFatalError (getLoc lhs) $
- 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." ]
+ _ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)
mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
@@ -383,15 +376,7 @@ mkRoleAnnotDecl loc tycon roles
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
in
- addFatalError loc_role
- (text "Illegal role name" <+> quotes (ppr role) $$
- suggestions nearby)
-
- suggestions [] = empty
- suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
- -- will this last case ever happen??
- suggestions list = hang (text "Perhaps you meant one of these:")
- 2 (pprWithCommas (quotes . ppr) list)
+ addFatalError $ Error (ErrIllegalRoleName role nearby) [] loc_role
-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
@@ -411,8 +396,7 @@ fromSpecTyVarBndr bndr = case bndr of
where
check_spec :: Specificity -> SrcSpan -> P ()
check_spec SpecifiedSpec _ = return ()
- check_spec InferredSpec loc = addFatalError loc
- (text "Inferred type variables are not allowed here")
+ check_spec InferredSpec loc = addFatalError $ Error ErrInferredTypeVarNotAllowed [] loc
{- **********************************************************************
@@ -463,10 +447,7 @@ cvBindsAndSigs fb = do
-- called on top-level declarations.
drop_bad_decls [] = return []
drop_bad_decls (L l (SpliceD _ d) : ds) = do
- addError l $
- hang (text "Declaration splices are allowed only" <+>
- text "at the top level:")
- 2 (ppr d)
+ addError $ Error (ErrDeclSpliceNotAtTopLevel d) [] l
drop_bad_decls ds
drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
@@ -571,17 +552,16 @@ 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 :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
+tyConToDataCon :: SrcSpan -> RdrName -> Either Error (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
- = Left (loc, msg)
+ = Left $ Error (ErrNotADataCon tc) [] loc
where
occ = rdrNameOcc tc
- msg = text "Not a data constructor:" <+> quotes (ppr tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
@@ -619,25 +599,17 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
- addFatalError loc $
- text "pattern synonym 'where' clause must contain a single binding:" $$
- ppr decl
+ addFatalError $ Error (ErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc
wrongNameBindingErr loc decl =
- addFatalError loc $
- text "pattern synonym 'where' clause must bind the pattern synonym's name"
- <+> quotes (ppr patsyn_name) $$ ppr decl
+ addFatalError $ Error (ErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc
wrongNumberErr loc =
- addFatalError loc $
- text "pattern synonym 'where' clause cannot be empty" $$
- text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
+ addFatalError $ Error (ErrEmptyWhereInPatSynDecl patsyn_name) [] loc
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr loc pat =
- addFatalError loc $
- text "record syntax not supported for pattern synonym declarations:" $$
- ppr pat
+ addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
@@ -761,12 +733,6 @@ data_con_ty_con dc
| otherwise -- See Note [setRdrNameSpace for wired-in names]
= Unqual (setOccNameSpace tcClsName (getOccName dc))
--- | Replaces constraint tuple names with corresponding boxed ones.
-filterCTuple :: RdrName -> RdrName
-filterCTuple (Exact n)
- | Just arity <- cTupleTyConNameArity_maybe n
- = Exact $ tupleTyConName BoxedTuple arity
-filterCTuple rdr = rdr
{- Note [setRdrNameSpace for wired-in names]
@@ -781,10 +747,10 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}
-eitherToP :: MonadP m => Either (SrcSpan, SDoc) a -> m a
+eitherToP :: MonadP m => Either Error a -> m a
-- Adapts the Either monad to the P monad
-eitherToP (Left (loc, doc)) = addFatalError loc doc
-eitherToP (Right thing) = return thing
+eitherToP (Left err) = addFatalError err
+eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P ( LHsQTyVars GhcPs -- the synthesized type variables
@@ -795,16 +761,9 @@ 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 loc $
- vcat [ text "Unexpected type application" <+>
- text "@" <> ppr ki
- , text "In the" <+> pp_what <+>
- ptext (sLit "declaration for") <+> quotes (ppr tc)]
+ check (HsTypeArg _ ki@(L loc _)) = addFatalError $ Error (ErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc
check (HsValArg ty) = chkParens [] ty
- check (HsArgPar sp) = addFatalError sp $
- vcat [text "Malformed" <+> pp_what
- <+> text "declaration for" <+> quotes (ppr tc)]
+ check (HsArgPar sp) = addFatalError $ Error (ErrMalformedDecl pp_what (unLoc tc)) [] sp
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs, [AddAnn])
@@ -820,23 +779,7 @@ checkTyVars pp_what equals_or_where tc tparms
chk (L l (HsTyVar _ _ (L ltv tv)))
| isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv)))
chk t@(L loc _)
- = addFatalError loc $
- vcat [ text "Unexpected type" <+> quotes (ppr t)
- , text "In the" <+> pp_what
- <+> ptext (sLit "declaration for") <+> quotes tc'
- , vcat[ (text "A" <+> pp_what
- <+> ptext (sLit "declaration should have form"))
- , nest 2
- (pp_what
- <+> tc'
- <+> hsep (map text (takeList tparms allNameStrings))
- <+> equals_or_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 $ fmap filterCTuple tc
-
+ = addFatalError $ Error (ErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc
whereDots, equalsDots :: SDoc
@@ -848,10 +791,7 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just c)
= do allowed <- getBit DatatypeContextsBit
- unless allowed $
- addError (getLoc c)
- (text "Illegal datatype context (use DatatypeContexts):"
- <+> pprLHsContext c)
+ unless allowed $ addError $ Error (ErrIllegalDataTypeContext c) [] (getLoc c)
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
@@ -879,16 +819,15 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one)
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
where check (L loc (Unqual occ)) = do
+ -- TODO: don't use string here, OccName has a Unique/FastString
when ((occNameString occ ==) `any` ["forall","family","role"])
- (addFatalError loc (text $ "parse error on input "
- ++ occNameString occ))
+ (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc)
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
- unless allowed $ addError loc $
- text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
+ unless allowed $ addError $ Error (ErrIllegalTraditionalRecordSyntax (ppr r)) [] loc
return lr
-- | Check if the gadt_constrlist is empty. Only raise parse error for
@@ -897,11 +836,7 @@ checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
- unless gadtSyntax $ addError span $ 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"
- ]
+ unless gadtSyntax $ addError $ Error ErrIllegalWhereInDataDecl [] span
return gadts
checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
@@ -923,7 +858,7 @@ checkTyClHdr is_cls ty
-- workaround to define '*' despite StarIsType
go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
- = do { warnStarBndr l
+ = do { addWarning Opt_WarnStarBinder (WarnStarBinder l)
; let name = mkOccName tcClsName (starSym isUni)
; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
@@ -942,8 +877,7 @@ 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 l (text "Malformed head of type or class declaration:"
- <+> ppr ty)
+ = addFatalError $ Error (ErrMalformedTyOrClDecl ty) [] l
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -954,34 +888,29 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = do
case unLoc expr of
- HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr
- HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr
- HsLam {} -> check (text "lambda expression") expr
- HsCase {} -> check (text "case expression") expr
- HsLamCase {} -> check (text "lambda-case expression") expr
- HsLet {} -> check (text "let expression") expr
- HsIf {} -> check (text "if expression") expr
- HsProc {} -> check (text "proc expression") expr
- _ -> return ()
+ HsDo _ (DoExpr m) _ -> check (ErrDoInFunAppExpr m) expr
+ HsDo _ (MDoExpr m) _ -> check (ErrMDoInFunAppExpr m) expr
+ HsLam {} -> check ErrLambdaInFunAppExpr expr
+ HsCase {} -> check ErrCaseInFunAppExpr expr
+ HsLamCase {} -> check ErrLambdaCaseInFunAppExpr expr
+ HsLet {} -> check ErrLetInFunAppExpr expr
+ HsIf {} -> check ErrIfInFunAppExpr expr
+ HsProc {} -> check ErrProcInFunAppExpr expr
+ _ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
- HsCmdLam {} -> check (text "lambda command") cmd
- HsCmdCase {} -> check (text "case command") cmd
- HsCmdIf {} -> check (text "if command") cmd
- HsCmdLet {} -> check (text "let command") cmd
- HsCmdDo {} -> check (text "do command") cmd
- _ -> return ()
-
- check :: Outputable a => SDoc -> Located a -> PV ()
- check element a = do
+ HsCmdLam {} -> check ErrLambdaCmdInFunAppCmd cmd
+ HsCmdCase {} -> check ErrCaseCmdInFunAppCmd cmd
+ HsCmdIf {} -> check ErrIfCmdInFunAppCmd cmd
+ HsCmdLet {} -> check ErrLetCmdInFunAppCmd cmd
+ HsCmdDo {} -> check ErrDoCmdInFunAppCmd cmd
+ _ -> return ()
+
+ check err a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
- addError (getLoc a) $
- text "Unexpected " <> element <> text " in function application:"
- $$ nest 4 (ppr a)
- $$ text "You could write it with parentheses"
- $$ text "Or perhaps you meant to enable BlockArguments?"
+ addError $ Error (err a) [] (getLoc a)
-- | Validate the context constraints and break up a context into a list
-- of predicates.
@@ -1044,8 +973,8 @@ checkImportDecl mPre mPost = do
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = runPV . checkLPat
-checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
-checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
+checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
+checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e@(L l _) = checkPat l e []
@@ -1059,7 +988,7 @@ checkPat loc (L l e@(PatBuilderVar (L _ c))) args
, pat_args = PrefixCon args
}
| not (null args) && patIsRec c =
- localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
+ add_hint SuggestRecursiveDo $
patFail l (ppr e)
checkPat loc (L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
@@ -1092,9 +1021,7 @@ checkAPat loc e0 = do
-- Improve error messages for the @-operator when the user meant an @-pattern
PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do
- addError (getLoc op) $
- text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$
- perhaps_as_pat
+ addError $ Error ErrAtInPatPos [] (getLoc op)
return (WildPat noExtField)
PatBuilderOpApp l (L cl c) r
@@ -1126,14 +1053,11 @@ checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
return (L l (fld { hsRecFieldArg = p }))
patFail :: SrcSpan -> SDoc -> PV a
-patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
+patFail loc e = addFatalError $ Error (ErrParseErrorInPat e) [] loc
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
-opIsAt :: RdrName -> Bool
-opIsAt e = e == mkUnqual varName (fsLit "@")
-
---------------------------------------------------------------------------
-- Check Equation Syntax
@@ -1166,7 +1090,7 @@ checkFunBind :: SrcStrictness
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
- = do ps <- runPV_msg param_hint (mapM checkLPat pats)
+ = do ps <- runPV_hints param_hints (mapM checkLPat pats)
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
@@ -1181,14 +1105,9 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
where
- param_hint
- | Infix <- is_infix
- = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$
- if opIsAt (unLoc fun) then perhaps_as_pat else empty
- | otherwise = empty
-
-perhaps_as_pat :: SDoc
-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
+ param_hints
+ | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]
+ | otherwise = []
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
@@ -1226,48 +1145,22 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
= return lrdr
checkValSigLhs lhs@(L l _)
- = addFatalError l ((text "Invalid type signature:" <+>
- ppr lhs <+> text ":: ...")
- $$ text hint)
- where
- hint | foreign_RDR `looks_like` lhs
- = "Perhaps you meant to use ForeignFunctionInterface?"
- | default_RDR `looks_like` lhs
- = "Perhaps you meant to use DefaultSignatures?"
- | pattern_RDR `looks_like` lhs
- = "Perhaps you meant to use PatternSynonyms?"
- | otherwise
- = "Should be of form <variable> :: <type>"
-
- -- A common error is to forget the ForeignFunctionInterface flag
- -- so check for that, and suggest. cf #3805
- -- Sadly 'foreign import' still barfs 'parse error' because
- -- 'import' is a keyword
- looks_like s (L _ (HsVar _ (L _ v))) = v == s
- looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
- looks_like _ _ = False
-
- foreign_RDR = mkUnqual varName (fsLit "foreign")
- default_RDR = mkUnqual varName (fsLit "default")
- pattern_RDR = mkUnqual varName (fsLit "pattern")
+ = addFatalError $ Error (ErrInvalidTypeSignature lhs) [] l
checkDoAndIfThenElse
:: (Outputable a, Outputable b, Outputable c)
- => Located a -> Bool -> b -> Bool -> Located c -> PV ()
-checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
- | semiThen || semiElse
- = do doAndIfThenElse <- getBit DoAndIfThenElseBit
- unless doAndIfThenElse $ do
- addError (combineLocs guardExpr elseExpr)
- (text "Unexpected semi-colons in conditional:"
- $$ nest 4 expr
- $$ text "Perhaps you meant to use DoAndIfThenElse?")
- | otherwise = return ()
- where pprOptSemi True = semi
- pprOptSemi False = empty
- expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
- text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
- text "else" <+> ppr elseExpr
+ => (a -> Bool -> b -> Bool -> c -> ErrorDesc)
+ -> Located a -> Bool -> Located b -> Bool -> Located c -> PV ()
+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
+ | semiThen || semiElse = do
+ doAndIfThenElse <- getBit DoAndIfThenElseBit
+ let e = err (unLoc guardExpr)
+ semiThen (unLoc thenExpr)
+ semiElse (unLoc elseExpr)
+ loc = combineLocs guardExpr elseExpr
+
+ unless doAndIfThenElse $ addError (Error e [] loc)
+ | otherwise = return ()
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
@@ -1373,8 +1266,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 l $ text "Invalid infix hole, expected an infix operator"
+ mkHsInfixHolePV l = addFatalError $ Error ErrInvalidInfixHole [] l
-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
-- parsing an expression, a command, or a pattern.
@@ -1530,13 +1422,10 @@ instance DisambECP (HsCmd GhcPs) where
return $ L l (HsCmdApp noExtField c e)
mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)
mkHsIfPV l c semi1 a semi2 b = do
- checkDoAndIfThenElse c semi1 a semi2 b
+ checkDoAndIfThenElse ErrSemiColonsInCondCmd c semi1 a semi2 b
return $ L l (mkHsCmdIf c a b)
mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)
- mkHsDoPV l (Just m) _ =
- cmdFail l $
- text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
- $$ text "qualified 'do' is not supported in commands."
+ mkHsDoPV l (Just m) _ = addFatalError $ Error (ErrQualifiedDoInCmd m) [] l
mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
mkHsVarPV (L l v) = cmdFail l (ppr v)
mkHsLitPV (L l a) = cmdFail l (ppr a)
@@ -1565,15 +1454,12 @@ instance DisambECP (HsCmd GhcPs) where
rejectPragmaPV _ = return ()
cmdFail :: SrcSpan -> SDoc -> PV a
-cmdFail loc e = addFatalError loc $
- hang (text "Parse error in command:") 2 (ppr e)
+cmdFail loc e = addFatalError $ Error (ErrParseErrorInCmd e) [] loc
instance DisambECP (HsExpr GhcPs) where
type Body (HsExpr GhcPs) = HsExpr
ecpFromCmd' (L l c) = do
- addError l $ vcat
- [ text "Arrow command found where an expression was expected:",
- nest 2 (ppr c) ]
+ addError $ Error (ErrArrowCmdInExpr c) [] l
return (L l hsHoleExpr)
ecpFromExp' = return
mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
@@ -1594,7 +1480,7 @@ instance DisambECP (HsExpr GhcPs) where
checkExpBlockArguments e
return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))
mkHsIfPV l c semi1 a semi2 b = do
- checkDoAndIfThenElse c semi1 a semi2 b
+ checkDoAndIfThenElse ErrSemiColonsInCondExpr c semi1 a semi2 b
return $ L l (mkHsIf c a b)
mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)
mkHsParPV l e = return $ L l (HsPar noExtField e)
@@ -1610,76 +1496,42 @@ instance DisambECP (HsExpr GhcPs) where
checkRecordSyntax (L l r)
mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
- mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
- mkHsAsPatPV l v e =
- patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
- text "Type application syntax requires a space before '@'"
- mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $
- text "Did you mean to add a space after the '~'?"
- mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
- text "Did you mean to add a space after the '!'?"
+ mkHsViewPatPV l a b = addError (Error (ErrViewPatInExpr a b) [] l)
+ >> return (L l hsHoleExpr)
+ mkHsAsPatPV l v e = addError (Error (ErrTypeAppWithoutSpace (unLoc v) e) [] l)
+ >> return (L l hsHoleExpr)
+ mkHsLazyPatPV l e = addError (Error (ErrLazyPatWithoutSpace e) [] l)
+ >> return (L l hsHoleExpr)
+ mkHsBangPatPV l e = addError (Error (ErrBangPatWithoutSpace e) [] l)
+ >> return (L l hsHoleExpr)
mkSumOrTuplePV = mkSumOrTupleExpr
rejectPragmaPV (L _ (OpApp _ _ _ e)) =
-- assuming left-associative parsing of operators
rejectPragmaPV e
- rejectPragmaPV (L l (HsPragE _ prag _)) =
- addError l $
- hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
- rejectPragmaPV _ = return ()
-
-patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
-patSynErr item l e explanation =
- do { addError l $
- sep [text item <+> text "in expression context:",
- nest 4 (ppr e)] $$
- explanation
- ; return (L l hsHoleExpr) }
+ rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ Error (ErrUnallowedPragma prag) [] l
+ rejectPragmaPV _ = return ()
hsHoleExpr :: HsExpr GhcPs
hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
--- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
-data PatBuilder p
- = PatBuilderPat (Pat p)
- | PatBuilderPar (Located (PatBuilder p))
- | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
- | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
- | PatBuilderVar (Located RdrName)
- | PatBuilderOverLit (HsOverLit GhcPs)
-
-instance Outputable (PatBuilder GhcPs) where
- ppr (PatBuilderPat p) = ppr p
- ppr (PatBuilderPar (L _ p)) = parens (ppr p)
- ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
- ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
- ppr (PatBuilderVar v) = ppr v
- ppr (PatBuilderOverLit l) = ppr l
-
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
- ecpFromCmd' (L l c) =
- addFatalError l $
- text "Command syntax in pattern:" <+> ppr c
- ecpFromExp' (L l e) =
- addFatalError l $
- text "Expression syntax in pattern:" <+> ppr e
- mkHsLamPV l _ = addFatalError l $
- text "Lambda-syntax in pattern." $$
- text "Pattern matching on functions is not possible."
- mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
+ ecpFromCmd' (L l c) = addFatalError $ Error (ErrArrowCmdInPat c) [] l
+ ecpFromExp' (L l e) = addFatalError $ Error (ErrArrowExprInPat e) [] l
+ mkHsLamPV l _ = addFatalError $ Error ErrLambdaInPat [] l
+ mkHsLetPV l _ _ = addFatalError $ Error ErrLetInPat [] l
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
- mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
- mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern"
+ mkHsCasePV l _ _ = addFatalError $ Error ErrCaseInPat [] l
+ mkHsLamCasePV l _ = addFatalError $ Error ErrLambdaCaseInPat [] l
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
- mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
- mkHsAppTypePV l _ _ = addFatalError l $
- text "Type applications in patterns are not yet supported"
- mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
- mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"
- mkHsParPV l p = return $ L l (PatBuilderPar p)
+ mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
+ mkHsAppTypePV l _ _ = addFatalError $ Error ErrTypeAppInPat [] l
+ mkHsIfPV l _ _ _ _ _ = addFatalError $ Error ErrIfTheElseInPat [] l
+ mkHsDoPV l _ _ = addFatalError $ Error ErrDoNotationInPat [] l
+ mkHsParPV l p = return $ L l (PatBuilderPar p)
mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedStringLitPat lit
@@ -1723,7 +1575,7 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat (L loc lit) =
case lit of
HsStringPrim _ _ -- Trac #13260
- -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
+ -> addFatalError $ Error (ErrIllegalUnboxedStringInPat lit) [] loc
_ -> return ()
mkPatRec ::
@@ -1739,7 +1591,7 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
, pat_args = RecCon (HsRecFields fs dd)
}
mkPatRec p _ =
- addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
+ addFatalError $ Error (ErrInvalidRecordCon (unLoc p)) [] (getLoc 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.
@@ -1770,34 +1622,6 @@ instance DisambTD (HsType GhcPs) where
mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
mkUnpackednessPV = addUnpackednessP
--- | An accumulator to build a prefix data constructor,
--- e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
---
--- @
--- 1. PrefixDataConBuilder [] MkT
--- 2. PrefixDataConBuilder [A] MkT
--- 3. PrefixDataConBuilder [A, B] MkT
--- 4. PrefixDataConBuilder [A, B, C] MkT
--- @
---
--- There are two reasons we have a separate builder type instead of using
--- @HsConDeclDetails GhcPs@ directly:
---
--- 1. It's faster, because 'OrdList' gives us constant-time snoc.
--- 2. Having a separate type helps ensure that we don't forget to finalize a
--- 'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
---
--- See Note [PatBuilder] for another builder type used in the parser.
--- Here the technique is similar, but the motivation is different.
-data DataConBuilder
- = PrefixDataConBuilder
- (OrdList (LHsType GhcPs)) -- Data constructor fields
- (Located RdrName) -- Data constructor name
- | InfixDataConBuilder
- (LHsType GhcPs) -- LHS field
- (Located RdrName) -- Data constructor name
- (LHsType GhcPs) -- RHS field
-
dataConBuilderCon :: DataConBuilder -> Located RdrName
dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
@@ -1818,12 +1642,6 @@ dataConBuilderDetails (PrefixDataConBuilder flds _)
dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
= InfixCon (hsLinear lhs) (hsLinear rhs)
-instance Outputable DataConBuilder where
- ppr (PrefixDataConBuilder flds data_con) =
- hang (ppr data_con) 2 (sep (map ppr (toList flds)))
- ppr (InfixDataConBuilder lhs data_con rhs) =
- ppr lhs <+> ppr data_con <+> ppr rhs
-
instance DisambTD DataConBuilder where
mkHsAppTyHeadPV = tyToDataConBuilder
@@ -1837,9 +1655,7 @@ instance DisambTD DataConBuilder where
panic "mkHsAppTyPV: InfixDataConBuilder"
mkHsAppKindTyPV lhs l_at ki =
- addFatalError l_at $
- hang (text "Unexpected kind application in a data/newtype declaration:") 2
- (ppr lhs <+> text "@" <> ppr ki)
+ addFatalError $ Error (ErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at
mkHsOpTyPV lhs (L l_tc tc) rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
@@ -1849,9 +1665,7 @@ instance DisambTD DataConBuilder where
l = combineLocs lhs rhs
check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
check_no_ops (HsOpTy{}) =
- addError l $
- hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
- 2 (ppr lhs <+> ppr tc <+> ppr rhs)
+ addError $ Error (ErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l
check_no_ops _ = return ()
mkUnpackednessPV unpk constr_stuff
@@ -1862,8 +1676,7 @@ instance DisambTD DataConBuilder where
let l = combineLocs unpk constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| otherwise =
- do addError (getLoc unpk) $
- text "{-# UNPACK #-} cannot be applied to a data constructor."
+ do addError $ Error ErrUnpackDataCon [] (getLoc unpk)
return constr_stuff
tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)
@@ -1874,9 +1687,7 @@ tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
let data_con = L l (getRdrName (tupleDataCon Boxed (length ts)))
return $ L l (PrefixDataConBuilder (toOL ts) data_con)
tyToDataConBuilder t =
- addFatalError (getLoc t) $
- hang (text "Cannot parse data constructor in a data/newtype declaration:")
- 2 (ppr t)
+ addFatalError $ Error (ErrInvalidDataCon (unLoc t)) [] (getLoc t)
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2325,7 +2136,7 @@ checkPrecP
checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
- | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
+ | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l
where
-- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
specialOp op = unLoc op `elem` [ eqTyCon_RDR
@@ -2341,7 +2152,7 @@ mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
- | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
+ | Just dd_loc <- dd = addFatalError $ Error ErrDotsInRecordUpdate [] dd_loc
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
@@ -2405,7 +2216,7 @@ 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 loc (text "Malformed entity string")
+ Nothing -> addFatalError $ Error ErrMalformedEntityString [] loc
Just importSpec -> returnSpec importSpec
-- currently, all the other import conventions only support a symbol name in
@@ -2543,20 +2354,12 @@ mkModuleImpExp (L l specname) subs =
in (\newName
-> IEThingWith noExtField (L l newName) pos ies [])
<$> nameT
- else addFatalError l
- (text "Illegal export form (use PatternSynonyms to enable)")
+ else addFatalError $ Error ErrIllegalPatSynExport [] l
where
name = ieNameVal specname
nameT =
if isVarNameSpace (rdrNameSpace name)
- then addFatalError l
- (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)
+ then addFatalError $ Error (ErrVarForTyCon name) [] l
else return $ ieNameFromSpec specname
ieNameVal (ImpExpQcName ln) = unLoc ln
@@ -2573,8 +2376,7 @@ mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
mkTypeImpExp name =
do allowed <- getBit ExplicitNamespacesBit
- unless allowed $ addError (getLoc name) $
- text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
+ unless allowed $ addError $ Error ErrIllegalExplicitNamespace [] (getLoc name)
return (fmap (`setRdrNameSpace` tcClsName) name)
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
@@ -2584,9 +2386,7 @@ checkImportSpec ie@(L _ specs) =
(l:_) -> importSpecError l
where
importSpecError l =
- addFatalError l
- (text "Illegal import form, this syntax can only be used to bundle"
- $+$ text "pattern synonyms with types in module exports.")
+ addFatalError $ Error ErrIllegalImportBundleForm [] l
-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
@@ -2607,53 +2407,21 @@ isImpExpQcWildcard _ = False
warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule span =
- addWarning Opt_WarnPrepositiveQualifiedModule span msg
- where
- msg = 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'"
+ addWarning Opt_WarnPrepositiveQualifiedModule (WarnImportPreQualified span)
failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
-failOpNotEnabledImportQualifiedPost loc = addError loc msg
- where
- msg = text "Found" <+> quotes (text "qualified")
- <+> text "in postpositive position. "
- $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+failOpNotEnabledImportQualifiedPost loc = addError $ Error ErrImportPostQualified [] loc
failOpImportQualifiedTwice :: SrcSpan -> P ()
-failOpImportQualifiedTwice loc = addError loc msg
- where
- msg = text "Multiple occurrences of 'qualified'"
+failOpImportQualifiedTwice loc = addError $ Error ErrImportQualifiedTwice [] loc
warnStarIsType :: SrcSpan -> P ()
-warnStarIsType span = addWarning Opt_WarnStarIsType span msg
- where
- msg = 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."
-
-warnStarBndr :: SrcSpan -> P ()
-warnStarBndr span = addWarning Opt_WarnStarBinder span msg
- where
- msg = 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."
+warnStarIsType span = addWarning Opt_WarnStarIsType (WarnStarIsType span)
failOpFewArgs :: MonadP m => Located RdrName -> m a
failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
- ; let msg = too_few $$ starInfo star_is_type op
- ; addFatalError loc msg }
- where
- too_few = text "Operator applied to too few arguments:" <+> ppr op
+ ; addFatalError $ Error (ErrOpFewArgs (StarIsType star_is_type) op) [] loc }
-----------------------------------------------------------------------------
-- Misc utils
@@ -2661,12 +2429,13 @@ failOpFewArgs (L loc op) =
data PV_Context =
PV_Context
{ pv_options :: ParserOpts
- , pv_hint :: SDoc -- See Note [Parser-Validator Hint]
+ , pv_hints :: [Hint] -- See Note [Parser-Validator Hint]
}
data PV_Accum =
PV_Accum
- { pv_messages :: DynFlags -> Messages
+ { pv_warnings :: Bag Warning
+ , pv_errors :: Bag Error
, pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
, pv_comment_q :: [RealLocated AnnotationComment]
, pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
@@ -2709,22 +2478,24 @@ instance Monad PV where
PV_Failed acc' -> PV_Failed acc'
runPV :: PV a -> P a
-runPV = runPV_msg empty
+runPV = runPV_hints []
-runPV_msg :: SDoc -> PV a -> P a
-runPV_msg msg m =
+runPV_hints :: [Hint] -> PV a -> P a
+runPV_hints hints m =
P $ \s ->
let
pv_ctx = PV_Context
{ pv_options = options s
- , pv_hint = msg }
+ , pv_hints = hints }
pv_acc = PV_Accum
- { pv_messages = messages s
+ { pv_warnings = warnings s
+ , pv_errors = errors s
, pv_annotations = annotations s
, pv_comment_q = comment_q s
, pv_annotations_comments = annotations_comments s }
mkPState acc' =
- s { messages = pv_messages acc'
+ s { warnings = pv_warnings acc'
+ , errors = pv_errors acc'
, annotations = pv_annotations acc'
, comment_q = pv_comment_q acc'
, annotations_comments = pv_annotations_comments acc' }
@@ -2733,21 +2504,24 @@ runPV_msg msg m =
PV_Ok acc' a -> POk (mkPState acc') a
PV_Failed acc' -> PFailed (mkPState acc')
-localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
-localPV_msg f m =
- let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in
+add_hint :: Hint -> 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 srcspan msg =
- PV $ \ctx acc@PV_Accum{pv_messages=m} ->
- let msg' = msg $$ pv_hint ctx in
- PV_Ok acc{pv_messages=appendError srcspan msg' m} ()
- addWarning option srcspan warning =
- PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->
- PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()
- addFatalError srcspan msg =
- addError srcspan msg >> PV (const PV_Failed)
+ addError err@(Error e hints loc) =
+ PV $ \ctx acc ->
+ let err' | null (pv_hints ctx) = err
+ | otherwise = Error 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 ()
+ addFatalError err =
+ addError err >> PV (const PV_Failed)
getBit ext =
PV $ \ctx acc ->
let b = ext `xtest` pExtsBitmap (pv_options ctx) in
@@ -2802,7 +2576,7 @@ We attempt to detect such cases and add a hint to the error messages:
Possibly caused by a missing 'do'?
The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
-as the 'pv_hint' field 'PV_Context'. When validating in a context other than
+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.
@@ -2813,27 +2587,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
- addError span
- (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
-
-data SumOrTuple b
- = Sum ConTag Arity (Located b)
- | Tuple [Located (Maybe (Located b))]
-
-pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
-pprSumOrTuple boxity = \case
- Sum alt arity e ->
- parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
- <+> parClose
- Tuple xs ->
- parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
- <> parClose
- where
- ppr_bars n = hsep (replicate n (Outputable.char '|'))
- (parOpen, parClose) =
- case boxity of
- Boxed -> (text "(", text ")")
- Unboxed -> (text "(#", text "#)")
+ addError $ Error (ErrIllegalBangPattern e) [] span
mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
@@ -2848,8 +2602,7 @@ mkSumOrTupleExpr l boxity (Tuple es) =
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
return $ L l (ExplicitSum noExtField alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
- addFatalError l (hang (text "Boxed sums not supported:") 2
- (pprSumOrTuple Boxed a))
+ addFatalError $ Error (ErrUnsupportedBoxedSumExpr a) [] l
mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
@@ -2860,7 +2613,7 @@ mkSumOrTuplePat l boxity (Tuple ps) = do
where
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
toTupPat (L l p) = case p of
- Nothing -> addFatalError l (text "Tuple section in pattern context")
+ Nothing -> addFatalError $ Error ErrTupleSectionInPat [] l
Just p' -> checkLPat p'
-- Sum
@@ -2868,8 +2621,7 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
- addFatalError l (hang (text "Boxed sums not supported:") 2
- (pprSumOrTuple Boxed a))
+ addFatalError $ Error (ErrUnsupportedBoxedSumPat a) [] l
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
@@ -2886,7 +2638,3 @@ mkMultTy t = HsExplicitMult t
starSym :: Bool -> String
starSym True = "★"
starSym False = "*"
-
-forallSym :: Bool -> String
-forallSym True = "∀"
-forallSym False = "forall"
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index feb0a32351..47e6756408 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -56,7 +56,6 @@ import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Driver.Session ( WarningFlag(..) )
-import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
import GHC.Data.Bag
@@ -73,6 +72,7 @@ import Data.Coerce
import qualified Data.Monoid
import GHC.Parser.Lexer
+import GHC.Parser.Errors
import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))
{- Note [Adding Haddock comments to the syntax tree]
@@ -193,12 +193,9 @@ addHaddockToModule lmod = do
reportHdkWarning :: HdkWarn -> P ()
reportHdkWarning (HdkWarnInvalidComment (L l _)) =
- addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $
- text "A Haddock comment cannot appear in this position and will be ignored."
+ addWarning Opt_WarnInvalidHaddock $ WarnHaddockInvalidPos (mkSrcSpanPs l)
reportHdkWarning (HdkWarnExtraComment (L l _)) =
- addWarning Opt_WarnInvalidHaddock l $
- text "Multiple Haddock comments for a single entity are not allowed." $$
- text "The extraneous comment will be ignored."
+ addWarning Opt_WarnInvalidHaddock $ WarnHaddockIgnoreMulti l
collectHdkWarnings :: HdkSt -> [HdkWarn]
collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =
diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs
new file mode 100644
index 0000000000..26795def9f
--- /dev/null
+++ b/compiler/GHC/Parser/Types.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module GHC.Parser.Types
+ ( SumOrTuple(..)
+ , pprSumOrTuple
+ , PatBuilder(..)
+ , DataConBuilder(..)
+ )
+where
+
+import GHC.Prelude
+import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader
+import GHC.Hs.Extension
+import GHC.Hs.Lit
+import GHC.Hs.Pat
+import GHC.Hs.Type
+import GHC.Utils.Outputable as Outputable
+import GHC.Data.OrdList
+
+import Data.Foldable
+
+data SumOrTuple b
+ = Sum ConTag Arity (Located b)
+ | Tuple [Located (Maybe (Located b))]
+
+pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
+pprSumOrTuple boxity = \case
+ Sum alt arity e ->
+ parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
+ <+> parClose
+ Tuple xs ->
+ parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
+ <> parClose
+ where
+ ppr_bars n = hsep (replicate n (Outputable.char '|'))
+ (parOpen, parClose) =
+ case boxity of
+ Boxed -> (text "(", text ")")
+ Unboxed -> (text "(#", text "#)")
+
+-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] in
+-- GHC.parser.PostProcess
+data PatBuilder p
+ = PatBuilderPat (Pat p)
+ | PatBuilderPar (Located (PatBuilder p))
+ | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
+ | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
+ | PatBuilderVar (Located RdrName)
+ | PatBuilderOverLit (HsOverLit GhcPs)
+
+instance Outputable (PatBuilder GhcPs) where
+ ppr (PatBuilderPat p) = ppr p
+ ppr (PatBuilderPar (L _ p)) = parens (ppr p)
+ ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
+ ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
+ ppr (PatBuilderVar v) = ppr v
+ ppr (PatBuilderOverLit l) = ppr l
+
+-- | An accumulator to build a prefix data constructor,
+-- e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
+--
+-- @
+-- 1. PrefixDataConBuilder [] MkT
+-- 2. PrefixDataConBuilder [A] MkT
+-- 3. PrefixDataConBuilder [A, B] MkT
+-- 4. PrefixDataConBuilder [A, B, C] MkT
+-- @
+--
+-- There are two reasons we have a separate builder type instead of using
+-- @HsConDeclDetails GhcPs@ directly:
+--
+-- 1. It's faster, because 'OrdList' gives us constant-time snoc.
+-- 2. Having a separate type helps ensure that we don't forget to finalize a
+-- 'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
+--
+-- See Note [PatBuilder] for another builder type used in the parser.
+-- Here the technique is similar, but the motivation is different.
+data DataConBuilder
+ = PrefixDataConBuilder
+ (OrdList (LHsType GhcPs)) -- Data constructor fields
+ (Located RdrName) -- Data constructor name
+ | InfixDataConBuilder
+ (LHsType GhcPs) -- LHS field
+ (Located RdrName) -- Data constructor name
+ (LHsType GhcPs) -- RHS field
+
+instance Outputable DataConBuilder where
+ ppr (PrefixDataConBuilder flds data_con) =
+ hang (ppr data_con) 2 (sep (map ppr (toList flds)))
+ ppr (InfixDataConBuilder lhs data_con rhs) =
+ ppr lhs <+> ppr data_con <+> ppr rhs
+
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 13978bf4f1..3344c7e3a1 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -57,7 +57,7 @@ import GHC.Types.Name.Reader
import GHC.Driver.Types
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
-import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )
+import GHC.Parser.PostProcess ( setRdrNameSpace )
import GHC.Builtin.RebindableNames
import GHC.Builtin.Types
import GHC.Types.Name
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 5c56abed90..27f1e20661 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -65,7 +65,10 @@ module GHC.Types.Name.Reader (
importSpecLoc, importSpecModule, isExplicitItem, bestImport,
-- * Utils for StarIsType
- starInfo
+ starInfo,
+
+ -- * Utils
+ opIsAt,
) where
#include "HsVersions.h"
@@ -1402,3 +1405,7 @@ starInfo star_is_type rdr_name =
= let fs = occNameFS occName
in fs == fsLit "*" || fs == fsLit "★"
| otherwise = False
+
+-- | Indicate if the given name is the "@" operator
+opIsAt :: RdrName -> Bool
+opIsAt e = e == mkUnqual varName (fsLit "@")
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index bad8a8b092..72b469f7d3 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -16,13 +16,12 @@ module GHC.Utils.Error (
Severity(..),
-- * Messages
- ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
- ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
+ ErrMsg(..),
+ ErrDoc(..), errDoc,
mapErrDoc,
WarnMsg, MsgDoc,
Messages, ErrorMessages, WarningMessages,
unionMessages,
- errMsgSpan, errMsgContext,
errorsFound, isEmptyMessages,
isWarnMsgFatal,
warningsToMessages,
@@ -194,7 +193,6 @@ data Severity
instance ToJson Severity where
json s = JSString (show s)
-
instance Show ErrMsg where
show em = errMsgShortString em
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0266513a13..20854a2a29 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -375,7 +375,6 @@ Library
GHC.Driver.Make
GHC.Plugins
GHC.Prelude
- GHC.Parser.Header
GHC.Driver.Main
GHC.Hs.Stats
GHC.Driver.Types
@@ -399,13 +398,17 @@ Library
GHC.Settings.IO
GHC.SysTools.Elf
GHC.Iface.Tidy
+ GHC.Parser
+ GHC.Parser.Annotation
GHC.Parser.CharClass
+ GHC.Parser.Errors
+ GHC.Parser.Errors.Ppr
+ GHC.Parser.Header
GHC.Parser.Lexer
- GHC.Core.Coercion.Opt
- GHC.Parser
GHC.Parser.PostProcess
GHC.Parser.PostProcess.Haddock
- GHC.Parser.Annotation
+ GHC.Parser.Types
+ GHC.Core.Coercion.Opt
GHC.Types.ForeignCall
GHC.Builtin.Uniques
GHC.Builtin.Utils
View Lorry Controller Status