Commit 1ffee940 authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

Fix warnings and fatal parsing errors

parent 1f1b9e35
Pipeline #2325 passed with stages
in 362 minutes and 39 seconds
......@@ -82,8 +82,7 @@ doBackpack [src_filename] = do
buf <- liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
case unP parseBackpack (mkPState dflags buf loc) of
PFailed _ span err -> do
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
PFailed pst -> throwErrors (getErrorMessages pst dflags)
POk _ pkgname_bkp -> do
-- OK, so we have an LHsUnit PackageName, but we want an
-- LHsUnit HsComponentId. So let's rename it.
......
......@@ -50,7 +50,7 @@ thenPD :: PD a -> (a -> PD b) -> PD b
(PD m) `thenPD` k = PD $ \d s ->
case m d s of
POk s1 a -> unPD (k a) d s1
PFailed warnFn span err -> PFailed warnFn span err
PFailed s1 -> PFailed s1
failPD :: String -> PD a
failPD = liftP . fail
......
......@@ -1424,11 +1424,8 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
case unPD cmmParse dflags init_state of
PFailed warnFn span err -> do
let msg = mkPlainErrMsg dflags span err
errMsgs = (emptyBag, unitBag msg)
warnMsgs = warnFn dflags
return (unionMessages warnMsgs errMsgs, Nothing)
PFailed pst ->
return (getMessages pst dflags, Nothing)
POk pst code -> do
st <- initC
let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
......
......@@ -22,6 +22,7 @@ module ErrUtils (
errMsgSpan, errMsgContext,
errorsFound, isEmptyMessages,
isWarnMsgFatal,
warningsToMessages,
-- ** Formatting
pprMessageBag, pprErrMsgBagWithLoc,
......@@ -359,6 +360,15 @@ isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
errorsFound :: DynFlags -> Messages -> Bool
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages dflags =
partitionBagWith $ \warn ->
case isWarnMsgFatal dflags warn of
Nothing -> Left warn
Just err_reason ->
Right warn{ errMsgSeverity = SevError
, errMsgReason = ErrReason err_reason }
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
......
......@@ -337,7 +337,7 @@ import Annotations
import Module
import Panic
import Platform
import Bag ( listToBag, unitBag )
import Bag ( listToBag )
import ErrUtils
import MonadUtils
import Util
......@@ -1363,9 +1363,9 @@ getTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed _ span err ->
PFailed pst ->
do dflags <- getDynFlags
liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
throwErrors (getErrorMessages pst dflags)
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
......@@ -1376,9 +1376,9 @@ getRichTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed _ span err ->
PFailed pst ->
do dflags <- getDynFlags
liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
throwErrors (getErrorMessages pst dflags)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
......@@ -1553,9 +1553,9 @@ parser str dflags filename =
in
case unP Parser.parseModule (mkPState dflags buf loc) of
PFailed warnFn span err ->
let (warns,_) = warnFn dflags in
(warns, Left $ unitBag (mkPlainErrMsg dflags span err))
PFailed pst ->
let (warns,errs) = getMessages pst dflags in
(warns, Left errs)
POk pst rdr_module ->
let (warns,_) = getMessages pst dflags in
......
......@@ -66,9 +66,9 @@ getImports :: DynFlags
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed _ span err -> do
PFailed pst -> do
-- assuming we're not logging warnings here as per below
parseError dflags span err
throwErrors (getErrorMessages pst dflags)
POk pst rdr_module -> do
let _ms@(_warns, errs) = getMessages pst dflags
-- don't log warnings: they'll be reported when we parse the file
......@@ -136,9 +136,6 @@ mkPrelImports this_mod loc implicit_prelude import_decls
ideclAs = Nothing,
ideclHiding = Nothing }
parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
--------------------------------------------------------------
-- Get options
--------------------------------------------------------------
......
......@@ -233,9 +233,15 @@ logWarningsReportErrors (warns,errs) = do
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
-- | Throw some errors.
throwErrors :: ErrorMessages -> Hsc a
throwErrors = liftIO . throwIO . mkSrcErr
-- | 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
logWarnings warns
dflags <- getDynFlags
(wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
liftIO $ printBagOfErrors dflags wWarns
throwErrors (unionBags errs wErrs)
-- | Deal with errors and warnings returned by a compilation step
--
......@@ -341,19 +347,18 @@ hscParse' mod_summary
| otherwise = parseModule
case unP parseMod (mkPState dflags buf loc) of
PFailed warnFn span err -> do
logWarningsReportErrors (warnFn dflags)
handleWarnings
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
PFailed pst ->
handleWarningsThrowErrors (getMessages pst dflags)
POk pst rdr_module -> do
logWarningsReportErrors (getMessages pst dflags)
let (warns, errs) = getMessages pst dflags
logWarnings warns
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
when (not $ isEmptyBag errs) $ throwErrors errs
-- To get the list of extra source files, we take the list
-- that the parser gave us,
......@@ -1023,7 +1028,7 @@ checkSafeImports tcg_env
| imv_is_safe v1 /= imv_is_safe v2
= do
dflags <- getDynFlags
throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
throwOneError $ mkPlainErrMsg dflags (imv_span v1)
(text "Module" <+> ppr (imv_name v1) <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
......@@ -1089,7 +1094,7 @@ hscCheckSafe' m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
Nothing -> throwOneError $ mkPlainErrMsg dflags l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
......@@ -1760,7 +1765,7 @@ hscParseExpr expr = do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
_ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
_ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
......@@ -1794,11 +1799,8 @@ hscParseThingWithLocation source linenumber parser str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
PFailed warnFn span err -> do
logWarningsReportErrors (warnFn dflags)
handleWarnings
let msg = mkPlainErrMsg dflags span err
throwErrors $ unitBag msg
PFailed pst -> do
handleWarningsThrowErrors (getMessages pst dflags)
POk pst thing -> do
logWarningsReportErrors (getMessages pst dflags)
......
......@@ -133,7 +133,7 @@ module HscTypes (
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
throwOneError, throwErrors, handleSourceError,
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
......@@ -278,8 +278,11 @@ srcErrorMessages (SourceError msgs) = msgs
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
throwOneError :: MonadIO m => ErrMsg -> m ab
throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
throwErrors :: MonadIO io => ErrorMessages -> io a
throwErrors = liftIO . throwIO . mkSrcErr
throwOneError :: MonadIO io => ErrMsg -> io a
throwOneError = throwErrors . unitBag
-- | A source error is an error that is caused by one or more errors in the
-- source code. A 'SourceError' is thrown by many functions in the
......
......@@ -816,14 +816,14 @@ isStmt :: DynFlags -> String -> Bool
isStmt dflags stmt =
case parseThing Parser.parseStmt dflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ _ _ -> False
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string has an import declaration.
hasImport :: DynFlags -> String -> Bool
hasImport dflags stmt =
case parseThing Parser.parseModule dflags stmt of
Lexer.POk _ thing -> hasImports thing
Lexer.PFailed _ _ _ -> False
Lexer.PFailed _ -> False
where
hasImports = not . null . hsmodImports . unLoc
......@@ -832,7 +832,7 @@ isImport :: DynFlags -> String -> Bool
isImport dflags stmt =
case parseThing Parser.parseImport dflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ _ _ -> False
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: DynFlags -> String -> Bool
......@@ -842,7 +842,7 @@ isDecl dflags stmt = do
case unLoc thing of
SpliceD _ _ -> False
_ -> True
Lexer.PFailed _ _ _ -> False
Lexer.PFailed _ -> False
parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
parseThing parser dflags stmt = do
......
......@@ -51,13 +51,13 @@ module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
getRealSrcLoc, getPState, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
failLocMsgP, srcParseFail,
getErrorMessages, getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
ExtBits(..), getBit,
addWarning, addError,
addWarning, addError, addFatalError,
lexTokenStream,
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
commentToAnnotation
......@@ -977,7 +977,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 failSpanMsgP (RealSrcSpan span) (text "Missing block")
else addFatalError (RealSrcSpan span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
......@@ -1923,17 +1923,18 @@ data LayoutContext
| Layout !Int !GenSemic
deriving Show
-- | The result of running a parser.
data ParseResult a
= POk PState a
| PFailed
(DynFlags -> Messages) -- A function that returns warnings that
-- accumulated during parsing, including
-- the warnings related to tabs.
SrcSpan -- The start and end of the text span related
-- to the error. Might be used in environments
-- which can show this span, e.g. by
-- highlighting it.
MsgDoc -- The error message
= POk -- ^ The parser has consumed a (possibly empty) prefix
-- of the input and produced a result. Use 'getMessages'
-- to check for accumulated warnings and non-fatal errors.
PState -- ^ The resulting parsing state. Can be used to resume parsing.
a -- ^ The resulting value.
| PFailed -- ^ The parser has consumed a (possibly empty) prefix
-- of the input and failed.
PState -- ^ The parsing state right before failure, including the fatal
-- parse error. 'getMessages' and 'getErrorMessages' must return
-- a non-empty bag of errors.
-- | Test whether a 'WarningFlag' is set
warnopt :: WarningFlag -> ParserFlags -> Bool
......@@ -2003,6 +2004,7 @@ data ALRLayout = ALRLayoutLet
| ALRLayoutOf
| ALRLayoutDo
-- | The parsing monad, isomorphic to @StateT PState Maybe@.
newtype P a = P { unP :: PState -> ParseResult a }
instance Functor P where
......@@ -2019,7 +2021,7 @@ instance Monad P where
#endif
instance MonadFail.MonadFail P where
fail = failP
fail = failMsgP
returnP :: a -> P a
returnP a = a `seq` (P $ \s -> POk s a)
......@@ -2028,27 +2030,16 @@ thenP :: P a -> (a -> P b) -> P b
(P m) `thenP` k = P $ \ s ->
case m s of
POk s1 a -> (unP (k a)) s1
PFailed warnFn span err -> PFailed warnFn span err
failP :: String -> P a
failP msg =
P $ \s ->
PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
PFailed s1 -> PFailed s1
failMsgP :: String -> P a
failMsgP msg =
P $ \s ->
PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
failMsgP msg = do
pState <- getPState
addFatalError (RealSrcSpan (last_loc pState)) (text msg)
failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
failLocMsgP loc1 loc2 str =
P $ \s ->
PFailed (getMessages s) (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg =
P $ \s ->
PFailed (getMessages s) span msg
addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
getPState :: P PState
getPState = P $ \s -> POk s s
......@@ -2477,6 +2468,18 @@ mkPStatePure options buf loc =
annotations_comments = []
}
-- | Add a non-fatal error. Use this when the parser can produce a result
-- despite the error.
--
-- For example, when GHC encounters a @forall@ in a type,
-- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
-- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
-- the accumulator.
--
-- Control flow wise, non-fatal errors act like warnings: they are added
-- to the accumulator and parsing continues. This allows GHC to report
-- more than one parse error per file.
--
addError :: SrcSpan -> SDoc -> P ()
addError srcspan msg
= P $ \s@PState{messages=m} ->
......@@ -2488,6 +2491,14 @@ addError srcspan msg
in (ws, es')
in POk s{messages=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 -> P a
addFatalError span msg =
addError span msg >> P PFailed
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
= P $ \s@PState{messages=m, options=o} ->
......@@ -2522,6 +2533,14 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d =
in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
mkWarnMsg d (RealSrcSpan s) 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
-- | 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
......@@ -2542,7 +2561,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
(_:tl) ->
POk s{ context = tl } ()
[] ->
PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
-- Push a new layout context at the indentation of the last token read.
pushCurrentContext :: GenSemic -> P ()
......@@ -2602,7 +2621,7 @@ srcParseErr options buf len
srcParseFail :: P a
srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
last_loc = last_loc } ->
PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
......
......@@ -973,13 +973,13 @@ maybe_safe :: { ([AddAnn],Bool) }
| {- empty -} { ([],False) }
maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
: STRING {% let pkgFS = getSTRING $1 in
if looksLikePackageName (unpackFS pkgFS)
then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))
else parseErrorSDoc (getLoc $1) $ vcat [
text "parse error" <> colon <+> quotes (ppr pkgFS),
: 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"] }
text "character in package name"]
; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
| {- empty -} { ([],Nothing) }
optqualified :: { ([AddAnn],Bool) }
......@@ -3668,7 +3668,7 @@ 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 failSpanMsgP (getLoc lt) (text err)
then addFatalError (getLoc lt) (text err)
else return s
-- Utilities for combining source spans
......@@ -3756,23 +3756,15 @@ fileSrcSpan = do
hintMultiWayIf :: SrcSpan -> P ()
hintMultiWayIf span = do
mwiEnabled <- getBit MultiWayIfBit
unless mwiEnabled $ parseErrorSDoc span $
unless mwiEnabled $ addError span $
text "Multi-way if-expressions need MultiWayIf turned on"
-- Hint about if usage for beginners
hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs)
hintIf span msg = do
mwiEnabled <- getBit MultiWayIfBit
if mwiEnabled
then parseErrorSDoc span $ text $ "parse error in if statement"
else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
-- Hint about explicit-forall
hintExplicitForall :: Located Token -> P ()
hintExplicitForall tok = do
forall <- getBit ExplicitForallBit
rulePrag <- getBit InRulePragBit
unless (forall || rulePrag) $ parseErrorSDoc (getLoc tok) $ vcat
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:" <+>
......@@ -3803,13 +3795,13 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a
reportEmptyDoubleQuotes span = do
thQuotes <- getBit ThQuotesBit
if thQuotes
then parseErrorSDoc span $ vcat
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 parseErrorSDoc span $ vcat
else addFatalError span $ vcat
[ text "Parser error on `''`"
, text "Character literals may not be empty"
]
......
......@@ -60,7 +60,7 @@ module RdrHsSyn (
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
parseErrorSDoc, hintBangPat,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
-- Help with processing exports
......@@ -357,7 +357,7 @@ mkRoleAnnotDecl loc tycon roles
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
in
parseErrorSDoc loc_role
addFatalError loc_role
(text "Illegal role name" <+> quotes (ppr role) $$
suggestions nearby)
parse_role _ = panic "parse_role: Impossible Match"
......@@ -427,7 +427,7 @@ cvBindsAndSigs fb = go (fromOL fb)
DocD _ d
-> return (bs, ss, ts, tfis, dfis, cL l d : docs)
SpliceD _ d
-> parseErrorSDoc l $
-> addFatalError l $
hang (text "Declaration splices are allowed only" <+>
text "at the top level:")
2 (ppr d)
......@@ -620,23 +620,23 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
fromDecl (dL->L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
parseErrorSDoc loc $
addFatalError loc $
text "pattern synonym 'where' clause must contain a single binding:" $$
ppr decl
wrongNameBindingErr loc decl =
parseErrorSDoc loc $
addFatalError loc $
text "pattern synonym 'where' clause must bind the pattern synonym's name"
<+> quotes (ppr patsyn_name) $$ ppr decl
wrongNumberErr loc =
parseErrorSDoc loc $
addFatalError loc $
text "pattern synonym 'where' clause cannot be empty" $$
text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr loc pat =
parseErrorSDoc loc $
addFatalError loc $
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
......@@ -816,7 +816,7 @@ checkTyVarsP pp_what equals_or_where tc tparms
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Left (loc, doc)) = addFatalError loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
......@@ -915,7 +915,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
where check (dL->L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
(parseErrorSDoc loc (text $ "parse error on input "
(addFatalError loc (text $ "parse error on input "
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
......@@ -977,7 +977,7 @@ checkTyClHdr is_cls ty
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
go l _ _ _ _
= parseErrorSDoc l (text "Malformed head of type or class declaration:"
= addFatalError l (text "Malformed head of type or class declaration:"
<+> ppr ty)
-- | Yield a parse error if we have a function applied directly to a do block
......@@ -1087,7 +1087,7 @@ checkAPat msg loc e0 = do
EWildPat _ -> return (WildPat noExt)
HsVar _ x -> return (VarPat noExt x)
HsLit _ (HsStringPrim _ _) -- (#13260)
-> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:"
-> addFatalError loc (text "Illegal unboxed string literal in pattern:"
$$ ppr e0)
HsLit _ l -> return (LitPat noExt l)
......@@ -1137,7 +1137,7 @@ checkAPat msg loc e0 = do
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
[e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:"
| otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
$$ ppr e0)
ExplicitSum _ alt arity expr -> do
......@@ -1168,7 +1168,7 @@ checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
return (cL l (fld { hsRecFieldArg = p }))
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg loc e = parseErrorSDoc loc err
patFail msg loc e = addFatalError loc err
where err = text "Parse error in pattern:" <+> ppr e
$$ msg
......@@ -1250,7 +1250,7 @@ checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
= return lrdr
checkValSigLhs lhs@(dL->L l _)
= parseErrorSDoc l ((text "Invalid type signature:" <+>
= addFatalError l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")