diff options
| -rw-r--r-- | compiler/GHC/Cmm/Lexer.x | 2 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Parser.y | 14 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Parser/Monad.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Parser.y | 18 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors.hs | 217 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 208 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Header.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 64 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 170 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 4 |
11 files changed, 353 insertions, 352 deletions
diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index 3828685645..85b06ea624 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -326,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) (Error ErrCmmLexer []) + AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer []) AlexSkip inp2 _ -> do setInput inp2 lexToken diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index b0a7465a48..c04c9b82ca 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -919,7 +919,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name = case lookupUFM machOps name of - Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) [] + Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) [] Just m -> return m exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) @@ -1081,12 +1081,12 @@ parseSafety :: String -> PD Safety parseSafety "safe" = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible -parseSafety str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedSafety str)) [] +parseSafety str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) [] parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr" = return AddrHint parseCmmHint "signed" = return SignedHint -parseCmmHint str = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedHint str)) [] +parseCmmHint str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) [] -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint @@ -1113,7 +1113,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 $ Error (ErrCmmParser (CmmUnknownMacro fun)) [] + Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) [] Just fcode -> return $ do args <- sequence args_code code (fcode args) @@ -1216,7 +1216,7 @@ foreignCall conv_string results_code expr_code args_code safety ret = do conv <- case conv_string of "C" -> return CCallConv "stdcall" -> return StdCallConv - _ -> failMsgPD $ Error (ErrCmmParser (CmmUnknownCConv conv_string)) [] + _ -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) [] return $ do platform <- getPlatform results <- sequence results_code @@ -1294,7 +1294,7 @@ primCall results_code name args_code = do platform <- PD.getPlatform case lookupUFM (callishMachOps platform) name of - Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) [] + Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) [] Just f -> return $ do results <- sequence results_code args <- sequence args_code @@ -1448,7 +1448,7 @@ initEnv profile = listToUFM [ ] where platform = profilePlatform profile -parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup) +parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe CmmGroup) parseCmmFile dflags home_unit filename = do buf <- hGetStringBuffer filename let diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs index b8aa0180d8..77124ad1b2 100644 --- a/compiler/GHC/Cmm/Parser/Monad.hs +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -47,7 +47,7 @@ instance Monad PD where liftP :: P a -> PD a liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> Error) -> PD a +failMsgPD :: (SrcSpan -> PsError) -> PD a failMsgPD = liftP . failMsgP returnPD :: a -> PD a diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 8685462e7d..63633d16a2 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -285,7 +285,7 @@ handleWarnings = do -- | log warning in the monad, and if there are errors then -- throw a SourceError exception. -logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc () +logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors @@ -294,7 +294,7 @@ logWarningsReportErrors (warnings,errors) = do -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed) -handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a +handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index e9de7eea78..50ebb93ebd 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -788,7 +788,7 @@ HYPHEN :: { [AddAnn] } | PREFIX_MINUS { [mj AnnMinus $1 ] } | VARSYM {% if (getVARSYM $1 == fsLit "-") then return [mj AnnMinus $1] - else do { addError $ Error ErrExpectedHyphen [] (getLoc $1) + else do { addError $ PsError PsErrExpectedHyphen [] (getLoc $1) ; return [] } } @@ -1087,7 +1087,7 @@ maybe_safe :: { ([AddAnn],Bool) } maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } : STRING {% do { let { pkgFS = getSTRING $1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $ - addError $ Error (ErrInvalidPackageName pkgFS) [] (getLoc $1) + addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1) ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } | {- empty -} { ([],Nothing) } @@ -1788,7 +1788,7 @@ rule_activation_marker :: { [AddAnn] } : PREFIX_TILDE { [mj AnnTilde $1] } | VARSYM {% if (getVARSYM $1 == fsLit "~") then return [mj AnnTilde $1] - else do { addError $ Error ErrInvalidRuleActivationMarker [] (getLoc $1) + else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1) ; return [] } } rule_explicit_activation :: { ([AddAnn] @@ -3847,7 +3847,7 @@ getSCC :: Located Token -> P FastString getSCC lt = do let s = getSTRING lt -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s - then addFatalError $ Error ErrSpaceInSCC [] (getLoc lt) + then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt) else return s -- Utilities for combining source spans @@ -3937,7 +3937,7 @@ fileSrcSpan = do hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do linearEnabled <- getBit LinearTypesBit - unless linearEnabled $ addError $ Error ErrLinearFunction [] span + unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span -- Does this look like (a %m)? looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool @@ -3956,14 +3956,14 @@ looksLikeMult ty1 l_op ty2 hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit - unless mwiEnabled $ addError $ Error ErrMultiWayIf [] span + unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit - unless (forall || rulePrag) $ addError $ Error (ErrExplicitForall (isUnicode tok)) [] (getLoc tok) + unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok) -- Hint about qualified-do hintQualifiedDo :: Located Token -> P () @@ -3971,7 +3971,7 @@ hintQualifiedDo tok = do qualifiedDo <- getBit QualifiedDoBit case maybeQDoDoc of Just qdoDoc | not qualifiedDo -> - addError $ Error (ErrIllegalQualifiedDo qdoDoc) [] (getLoc tok) + addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok) _ -> return () where maybeQDoDoc = case unLoc tok of @@ -3985,7 +3985,7 @@ hintQualifiedDo tok = do reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit - addFatalError $ Error (ErrEmptyDoubleQuotes thQuotes) [] span + addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span {- %************************************************************************ diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index 582b47535d..f2b724160e 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -1,11 +1,11 @@ module GHC.Parser.Errors - ( Warning(..) + ( PsWarning(..) , TransLayoutReason(..) , OperatorWhitespaceSymbol(..) , OperatorWhitespaceOccurrence(..) , NumUnderscoreReason(..) - , Error(..) - , ErrorDesc(..) + , PsError(..) + , PsErrorDesc(..) , LexErr(..) , CmmParserError(..) , LexErrKind(..) @@ -30,37 +30,38 @@ import GHC.Utils.Outputable (SDoc) import GHC.Data.FastString import GHC.Unit.Module.Name -data Warning +-- | A warning that might arise during parsing. +data PsWarning -- | Warn when tabulations are found - = WarnTab + = PsWarnTab { tabFirst :: !SrcSpan -- ^ First occurence of a tab , tabCount :: !Word -- ^ Number of other occurences } - | WarnTransitionalLayout !SrcSpan !TransLayoutReason + | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason -- ^ Transitional layout warnings - | WarnUnrecognisedPragma !SrcSpan + | PsWarnUnrecognisedPragma !SrcSpan -- ^ Unrecognised pragma - | WarnHaddockInvalidPos !SrcSpan + | PsWarnHaddockInvalidPos !SrcSpan -- ^ Invalid Haddock comment position - | WarnHaddockIgnoreMulti !SrcSpan + | PsWarnHaddockIgnoreMulti !SrcSpan -- ^ Multiple Haddock comment for the same entity - | WarnStarBinder !SrcSpan + | PsWarnStarBinder !SrcSpan -- ^ Found binding occurence of "*" while StarIsType is enabled - | WarnStarIsType !SrcSpan + | PsWarnStarIsType !SrcSpan -- ^ Using "*" for "Type" without StarIsType enabled - | WarnImportPreQualified !SrcSpan + | PsWarnImportPreQualified !SrcSpan -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled - | WarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol - | WarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence + | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol + | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence -- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning. data OperatorWhitespaceSymbol @@ -78,146 +79,146 @@ 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 +data PsError = PsError + { errDesc :: !PsErrorDesc -- ^ Error description , errHints :: ![Hint] -- ^ Hints , errLoc :: !SrcSpan -- ^ Error position } -data ErrorDesc - = ErrLambdaCase +data PsErrorDesc + = PsErrLambdaCase -- ^ LambdaCase syntax used without the extension enabled - | ErrNumUnderscores !NumUnderscoreReason + | PsErrNumUnderscores !NumUnderscoreReason -- ^ Underscores in literals without the extension enabled - | ErrPrimStringInvalidChar + | PsErrPrimStringInvalidChar -- ^ Invalid character in primitive string - | ErrMissingBlock + | PsErrMissingBlock -- ^ Missing block - | ErrLexer !LexErr !LexErrKind + | PsErrLexer !LexErr !LexErrKind -- ^ Lexer error - | ErrSuffixAT + | PsErrSuffixAT -- ^ Suffix occurence of `@` - | ErrParse !String + | PsErrParse !String -- ^ Parse errors - | ErrCmmLexer + | PsErrCmmLexer -- ^ Cmm lexer error - | ErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs)) + | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs)) -- ^ Unsupported boxed sum in expression - | ErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs)) + | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs)) -- ^ Unsupported boxed sum in pattern - | ErrUnexpectedQualifiedConstructor !RdrName + | PsErrUnexpectedQualifiedConstructor !RdrName -- ^ Unexpected qualified constructor - | ErrTupleSectionInPat + | PsErrTupleSectionInPat -- ^ Tuple section in pattern context - | ErrIllegalBangPattern !(Pat GhcPs) + | PsErrIllegalBangPattern !(Pat GhcPs) -- ^ Bang-pattern without BangPattterns enabled - | ErrOpFewArgs !StarIsType !RdrName + | PsErrOpFewArgs !StarIsType !RdrName -- ^ Operator applied to too few arguments - | ErrImportQualifiedTwice + | PsErrImportQualifiedTwice -- ^ Import: multiple occurrences of 'qualified' - | ErrImportPostQualified + | PsErrImportPostQualified -- ^ Post qualified import without 'ImportQualifiedPost' - | ErrIllegalExplicitNamespace + | PsErrIllegalExplicitNamespace -- ^ Explicit namespace keyword without 'ExplicitNamespaces' - | ErrVarForTyCon !RdrName + | PsErrVarForTyCon !RdrName -- ^ Expecting a type constructor but found a variable - | ErrIllegalPatSynExport + | PsErrIllegalPatSynExport -- ^ Illegal export form allowed by PatternSynonyms - | ErrMalformedEntityString + | PsErrMalformedEntityString -- ^ Malformed entity string - | ErrDotsInRecordUpdate + | PsErrDotsInRecordUpdate -- ^ Dots used in record update - | ErrPrecedenceOutOfRange !Int + | PsErrPrecedenceOutOfRange !Int -- ^ Precedence out of range - | ErrInvalidDataCon !(HsType GhcPs) + | PsErrInvalidDataCon !(HsType GhcPs) -- ^ Cannot parse data constructor in a data/newtype declaration - | ErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs) + | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs) -- ^ Cannot parse data constructor in a data/newtype declaration - | ErrUnpackDataCon + | PsErrUnpackDataCon -- ^ UNPACK applied to a data constructor - | ErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs) + | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs) -- ^ Unexpected kind application in data/newtype declaration - | ErrInvalidRecordCon !(PatBuilder GhcPs) + | PsErrInvalidRecordCon !(PatBuilder GhcPs) -- ^ Not a record constructor - | ErrIllegalUnboxedStringInPat !(HsLit GhcPs) + | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs) -- ^ Illegal unboxed string literal in pattern - | ErrDoNotationInPat + | PsErrDoNotationInPat -- ^ Do-notation in pattern - | ErrIfTheElseInPat + | PsErrIfTheElseInPat -- ^ If-then-else syntax in pattern - | ErrLambdaCaseInPat + | PsErrLambdaCaseInPat -- ^ Lambda-case in pattern - | ErrCaseInPat + | PsErrCaseInPat -- ^ case..of in pattern - | ErrLetInPat + | PsErrLetInPat -- ^ let-syntax in pattern - | ErrLambdaInPat + | PsErrLambdaInPat -- ^ Lambda-syntax in pattern - | ErrArrowExprInPat !(HsExpr GhcPs) + | PsErrArrowExprInPat !(HsExpr GhcPs) -- ^ Arrow expression-syntax in pattern - | ErrArrowCmdInPat !(HsCmd GhcPs) + | PsErrArrowCmdInPat !(HsCmd GhcPs) -- ^ Arrow command-syntax in pattern - | ErrArrowCmdInExpr !(HsCmd GhcPs) + | PsErrArrowCmdInExpr !(HsCmd GhcPs) -- ^ Arrow command-syntax in expression - | ErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs) + | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs) -- ^ View-pattern in expression - | ErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) + | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) -- ^ Type-application without space before '@' - | ErrLazyPatWithoutSpace !(LHsExpr GhcPs) + | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs) -- ^ Lazy-pattern ('~') without space after it - | ErrBangPatWithoutSpace !(LHsExpr GhcPs) + | PsErrBangPatWithoutSpace !(LHsExpr GhcPs) -- ^ Bang-pattern ('!') without space after it - | ErrUnallowedPragma !(HsPragE GhcPs) + | PsErrUnallowedPragma !(HsPragE GhcPs) -- ^ Pragma not allowed in this position - | ErrQualifiedDoInCmd !ModuleName + | PsErrQualifiedDoInCmd !ModuleName -- ^ Qualified do block in command - | ErrInvalidInfixHole + | PsErrInvalidInfixHole -- ^ Invalid infix hole, expected an infix operator - | ErrSemiColonsInCondExpr + | PsErrSemiColonsInCondExpr -- ^ Unexpected semi-colons in conditional expression !(HsExpr GhcPs) -- ^ conditional expr !Bool -- ^ "then" semi-colon? @@ -225,7 +226,7 @@ data ErrorDesc !Bool -- ^ "else" semi-colon? !(HsExpr GhcPs) -- ^ "else" expr - | ErrSemiColonsInCondCmd + | PsErrSemiColonsInCondCmd -- ^ Unexpected semi-colons in conditional command !(HsExpr GhcPs) -- ^ conditional expr !Bool -- ^ "then" semi-colon? @@ -233,143 +234,143 @@ data ErrorDesc !Bool -- ^ "else" semi-colon? !(HsCmd GhcPs) -- ^ "else" expr - | ErrAtInPatPos + | PsErrAtInPatPos -- ^ @-operator in a pattern position - | ErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs) + | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs) -- ^ Unexpected lambda command in function application - | ErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) + | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) -- ^ Unexpected case command in function application - | ErrIfCmdInFunAppCmd !(LHsCmd GhcPs) + | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs) -- ^ Unexpected if command in function application - | ErrLetCmdInFunAppCmd !(LHsCmd GhcPs) + | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs) -- ^ Unexpected let command in function application - | ErrDoCmdInFunAppCmd !(LHsCmd GhcPs) + | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs) -- ^ Unexpected do command in function application - | ErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) -- ^ Unexpected do block in function application - | ErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) -- ^ Unexpected mdo block in function application - | ErrLambdaInFunAppExpr !(LHsExpr GhcPs) + | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected lambda expression in function application - | ErrCaseInFunAppExpr !(LHsExpr GhcPs) + | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected case expression in function application - | ErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs) + | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected lambda-case expression in function application - | ErrLetInFunAppExpr !(LHsExpr GhcPs) + | PsErrLetInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected let expression in function application - | ErrIfInFunAppExpr !(LHsExpr GhcPs) + | PsErrIfInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected if expression in function application - | ErrProcInFunAppExpr !(LHsExpr GhcPs) + | PsErrProcInFunAppExpr !(LHsExpr GhcPs) -- ^ Unexpected proc expression in function application - | ErrMalformedTyOrClDecl !(LHsType GhcPs) + | PsErrMalformedTyOrClDecl !(LHsType GhcPs) -- ^ Malformed head of type or class declaration - | ErrIllegalWhereInDataDecl + | PsErrIllegalWhereInDataDecl -- ^ Illegal 'where' keyword in data declaration - | ErrIllegalDataTypeContext !(LHsContext GhcPs) + | PsErrIllegalDataTypeContext !(LHsContext GhcPs) -- ^ Illegal datatyp context - | ErrParseErrorOnInput !OccName + | PsErrParseErrorOnInput !OccName -- ^ Parse error on input - | ErrMalformedDecl !SDoc !RdrName + | PsErrMalformedDecl !SDoc !RdrName -- ^ Malformed ... declaration for ... - | ErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName + | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName -- ^ Unexpected type application in a declaration - | ErrNotADataCon !RdrName + | PsErrNotADataCon !RdrName -- ^ Not a data constructor - | ErrRecordSyntaxInPatSynDecl !(LPat GhcPs) + | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs) -- ^ Record syntax used in pattern synonym declaration - | ErrEmptyWhereInPatSynDecl !RdrName + | PsErrEmptyWhereInPatSynDecl !RdrName -- ^ Empty 'where' clause in pattern-synonym declaration - | ErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration - | ErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration - | ErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs) + | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs) -- ^ Declaration splice not a top-level - | ErrInferredTypeVarNotAllowed + | PsErrInferredTypeVarNotAllowed -- ^ Inferred type variables not allowed here - | ErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs] + | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs] -- ^ Multiple names in standalone kind signatures - | ErrIllegalImportBundleForm + | PsErrIllegalImportBundleForm -- ^ Illegal import bundle form - | ErrIllegalRoleName !FastString [Role] + | PsErrIllegalRoleName !FastString [Role] -- ^ Illegal role name - | ErrInvalidTypeSignature !(LHsExpr GhcPs) + | PsErrInvalidTypeSignature !(LHsExpr GhcPs) -- ^ Invalid type signature - | ErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc + | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc -- ^ Unexpected type in declaration - | ErrExpectedHyphen + | PsErrExpectedHyphen -- ^ Expected a hyphen - | ErrSpaceInSCC + | PsErrSpaceInSCC -- ^ Found a space in a SCC - | ErrEmptyDoubleQuotes !Bool-- Is TH on? + | PsErrEmptyDoubleQuotes !Bool-- Is TH on? -- ^ Found two single quotes - | ErrInvalidPackageName !FastString + | PsErrInvalidPackageName !FastString -- ^ Invalid package name - | ErrInvalidRuleActivationMarker + | PsErrInvalidRuleActivationMarker -- ^ Invalid rule activation marker - | ErrLinearFunction + | PsErrLinearFunction -- ^ Linear function found but LinearTypes not enabled - | ErrMultiWayIf + | PsErrMultiWayIf -- ^ Multi-way if-expression found but MultiWayIf not enabled - | ErrExplicitForall !Bool -- is Unicode forall? + | PsErrExplicitForall !Bool -- is Unicode forall? -- ^ Explicit forall found but no extension allowing it is enabled - | ErrIllegalQualifiedDo !SDoc + | PsErrIllegalQualifiedDo !SDoc -- ^ Found qualified-do without QualifiedDo enabled - | ErrCmmParser !CmmParserError + | PsErrCmmParser !CmmParserError -- ^ Cmm parser error - | ErrIllegalTraditionalRecordSyntax !SDoc + | PsErrIllegalTraditionalRecordSyntax !SDoc -- ^ Illegal traditional record syntax -- -- TODO: distinguish errors without using SDoc - | ErrParseErrorInCmd !SDoc + | PsErrParseErrorInCmd !SDoc -- ^ Parse error in command -- -- TODO: distinguish errors without using SDoc - | ErrParseErrorInPat !SDoc + | PsErrParseErrorInPat !SDoc -- ^ Parse error in pattern -- -- TODO: distinguish errors without using SDoc diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index a26f6809c6..edb9b04380 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -44,9 +44,9 @@ mkParserWarn flag span doc = ErrMsg , errMsgReason = Reason flag } -pprWarning :: Warning -> ErrMsg +pprWarning :: PsWarning -> ErrMsg pprWarning = \case - WarnTab loc tc + PsWarnTab loc tc -> mkParserWarn Opt_WarnTabs loc $ text "Tab character found here" <> (if tc == 1 @@ -55,7 +55,7 @@ pprWarning = \case <> text "." $+$ text "Please use spaces instead." - WarnTransitionalLayout loc reason + PsWarnTransitionalLayout loc reason -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $ text "transitional layout will not be accepted in the future:" $$ text (case reason of @@ -63,20 +63,20 @@ pprWarning = \case TransLayout_Pipe -> "`|' at the same depth as implicit layout block" ) - WarnUnrecognisedPragma loc + PsWarnUnrecognisedPragma loc -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $ text "Unrecognised pragma" - WarnHaddockInvalidPos loc + PsWarnHaddockInvalidPos loc -> mkParserWarn Opt_WarnInvalidHaddock loc $ text "A Haddock comment cannot appear in this position and will be ignored." - WarnHaddockIgnoreMulti loc + PsWarnHaddockIgnoreMulti 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 + PsWarnStarBinder loc -> mkParserWarn Opt_WarnStarBinder loc $ text "Found binding occurrence of" <+> quotes (text "*") <+> text "yet StarIsType is enabled." @@ -84,7 +84,7 @@ pprWarning = \case <+> text "modules with StarIsType," $$ text " including the definition module, you must qualify it." - WarnStarIsType loc + PsWarnStarIsType loc -> mkParserWarn Opt_WarnStarIsType loc $ text "Using" <+> quotes (text "*") <+> text "(or its Unicode variant) to mean" @@ -94,7 +94,7 @@ pprWarning = \case $$ text "Suggested fix: use" <+> quotes (text "Type") <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." - WarnImportPreQualified loc + PsWarnImportPreQualified loc -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $ text "Found" <+> quotes (text "qualified") <+> text "in prepositive position" @@ -102,7 +102,7 @@ pprWarning = \case <+> text "after the module name instead." $$ text "To allow this, enable language extension 'ImportQualifiedPost'" - WarnOperatorWhitespaceExtConflict loc sym + PsWarnOperatorWhitespaceExtConflict loc sym -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $ let mk_prefix_msg operator_symbol extension_name syntax_meaning = text "The prefix use of a" <+> quotes (text operator_symbol) @@ -117,7 +117,7 @@ pprWarning = \case OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice" - WarnOperatorWhitespace loc sym occ_type + PsWarnOperatorWhitespace loc sym occ_type -> mkParserWarn Opt_WarnOperatorWhitespace loc $ let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) @@ -130,27 +130,27 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: Error -> ErrMsg +pprError :: PsError -> ErrMsg pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) -pp_err :: ErrorDesc -> SDoc +pp_err :: PsErrorDesc -> SDoc pp_err = \case - ErrLambdaCase + PsErrLambdaCase -> text "Illegal lambda-case (use LambdaCase)" - ErrNumUnderscores reason + PsErrNumUnderscores reason -> text $ case reason of NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals" NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals" - ErrPrimStringInvalidChar + PsErrPrimStringInvalidChar -> text "primitive string literal must contain only characters <= \'\\xFF\'" - ErrMissingBlock + PsErrMissingBlock -> text "Missing block" - ErrLexer err kind + PsErrLexer err kind -> hcat [ text $ case err of LexError -> "lexical error" @@ -170,53 +170,53 @@ pp_err = \case LexErrKind_Char c -> " at character " ++ show c ] - ErrSuffixAT + PsErrSuffixAT -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." - ErrParse token + PsErrParse token | null token -> text "parse error (possibly incorrect indentation or mismatched brackets)" | otherwise -> text "parse error on input" <+> quotes (text token) - ErrCmmLexer + PsErrCmmLexer -> text "Cmm lexical error" - ErrUnsupportedBoxedSumExpr s + PsErrUnsupportedBoxedSumExpr s -> hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed s) - ErrUnsupportedBoxedSumPat s + PsErrUnsupportedBoxedSumPat s -> hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed s) - ErrUnexpectedQualifiedConstructor v + PsErrUnexpectedQualifiedConstructor v -> hang (text "Expected an unqualified type constructor:") 2 (ppr v) - ErrTupleSectionInPat + PsErrTupleSectionInPat -> text "Tuple section in pattern context" - ErrIllegalBangPattern e + PsErrIllegalBangPattern e -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e - ErrOpFewArgs (StarIsType star_is_type) op + PsErrOpFewArgs (StarIsType star_is_type) op -> text "Operator applied to too few arguments:" <+> ppr op $$ starInfo star_is_type op - ErrImportQualifiedTwice + PsErrImportQualifiedTwice -> text "Multiple occurrences of 'qualified'" - ErrImportPostQualified + PsErrImportPostQualified -> text "Found" <+> quotes (text "qualified") <+> text "in postpositive position. " $$ text "To allow this, enable language extension 'ImportQualifiedPost'" - ErrIllegalExplicitNamespace + PsErrIllegalExplicitNamespace -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" - ErrVarForTyCon name + PsErrVarForTyCon name -> text "Expecting a type constructor but found a variable," <+> quotes (ppr name) <> text "." $$ if isSymOcc $ rdrNameOcc name @@ -224,114 +224,114 @@ pp_err = \case <+> text "then enable ExplicitNamespaces and use the 'type' keyword." else empty - ErrIllegalPatSynExport + PsErrIllegalPatSynExport -> text "Illegal export form (use PatternSynonyms to enable)" - ErrMalformedEntityString + PsErrMalformedEntityString -> text "Malformed entity string" - ErrDotsInRecordUpdate + PsErrDotsInRecordUpdate -> text "You cannot use `..' in a record update" - ErrPrecedenceOutOfRange i + PsErrPrecedenceOutOfRange i -> text "Precedence out of range: " <> int i - ErrInvalidDataCon t + PsErrInvalidDataCon t -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 (ppr t) - ErrInvalidInfixDataCon lhs tc rhs + PsErrInvalidInfixDataCon lhs tc rhs -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2 (ppr lhs <+> ppr tc <+> ppr rhs) - ErrUnpackDataCon + PsErrUnpackDataCon -> text "{-# UNPACK #-} cannot be applied to a data constructor." - ErrUnexpectedKindAppInDataCon lhs ki + PsErrUnexpectedKindAppInDataCon lhs ki -> hang (text "Unexpected kind application in a data/newtype declaration:") 2 (ppr lhs <+> text "@" <> ppr ki) - ErrInvalidRecordCon p + PsErrInvalidRecordCon p -> text "Not a record constructor:" <+> ppr p - ErrIllegalUnboxedStringInPat lit + PsErrIllegalUnboxedStringInPat lit -> text "Illegal unboxed string literal in pattern:" $$ ppr lit - ErrDoNotationInPat + PsErrDoNotationInPat -> text "do-notation in pattern" - ErrIfTheElseInPat + PsErrIfTheElseInPat -> text "(if ... then ... else ...)-syntax in pattern" - ErrLambdaCaseInPat + PsErrLambdaCaseInPat -> text "(\\case ...)-syntax in pattern" - ErrCaseInPat + PsErrCaseInPat -> text "(case ... of ...)-syntax in pattern" - ErrLetInPat + PsErrLetInPat -> text "(let ... in ...)-syntax in pattern" - ErrLambdaInPat + PsErrLambdaInPat -> text "Lambda-syntax in pattern." $$ text "Pattern matching on functions is not possible." - ErrArrowExprInPat e + PsErrArrowExprInPat e -> text "Expression syntax in pattern:" <+> ppr e - ErrArrowCmdInPat c + PsErrArrowCmdInPat c -> text "Command syntax in pattern:" <+> ppr c - ErrArrowCmdInExpr c + PsErrArrowCmdInExpr c -> vcat [ text "Arrow command found where an expression was expected:" , nest 2 (ppr c) ] - ErrViewPatInExpr a b + PsErrViewPatInExpr a b -> sep [ text "View pattern in expression context:" , nest 4 (ppr a <+> text "->" <+> ppr b) ] - ErrTypeAppWithoutSpace v e + PsErrTypeAppWithoutSpace 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 + PsErrLazyPatWithoutSpace 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 + PsErrBangPatWithoutSpace 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 + PsErrUnallowedPragma prag -> hang (text "A pragma is not allowed in this position:") 2 (ppr prag) - ErrQualifiedDoInCmd m + PsErrQualifiedDoInCmd m -> hang (text "Parse error in command:") 2 $ text "Found a qualified" <+> ppr m <> text ".do block in a command, but" $$ text "qualified 'do' is not supported in commands." - ErrParseErrorInCmd s + PsErrParseErrorInCmd s -> hang (text "Parse error in command:") 2 s - ErrParseErrorInPat s + PsErrParseErrorInPat s -> text "Parse error in pattern:" <+> s - ErrInvalidInfixHole + PsErrInvalidInfixHole -> text "Invalid infix hole, expected an infix operator" - ErrSemiColonsInCondExpr c st t se e + PsErrSemiColonsInCondExpr c st t se e -> text "Unexpected semi-colons in conditional:" $$ nest 4 expr $$ text "Perhaps you meant to use DoAndIfThenElse?" @@ -342,7 +342,7 @@ pp_err = \case text "then" <+> ppr t <> pprOptSemi se <+> text "else" <+> ppr e - ErrSemiColonsInCondCmd c st t se e + PsErrSemiColonsInCondCmd c st t se e -> text "Unexpected semi-colons in conditional:" $$ nest 4 expr $$ text "Perhaps you meant to use DoAndIfThenElse?" @@ -354,78 +354,78 @@ pp_err = \case text "else" <+> ppr e - ErrAtInPatPos + PsErrAtInPatPos -> text "Found a binding for the" <+> quotes (text "@") <+> text "operator in a pattern position." $$ perhaps_as_pat - ErrLambdaCmdInFunAppCmd a + PsErrLambdaCmdInFunAppCmd a -> pp_unexpected_fun_app (text "lambda command") a - ErrCaseCmdInFunAppCmd a + PsErrCaseCmdInFunAppCmd a -> pp_unexpected_fun_app (text "case command") a - ErrIfCmdInFunAppCmd a + PsErrIfCmdInFunAppCmd a -> pp_unexpected_fun_app (text "if command") a - ErrLetCmdInFunAppCmd a + PsErrLetCmdInFunAppCmd a -> pp_unexpected_fun_app (text "let command") a - ErrDoCmdInFunAppCmd a + PsErrDoCmdInFunAppCmd a -> pp_unexpected_fun_app (text "do command") a - ErrDoInFunAppExpr m a + PsErrDoInFunAppExpr m a -> pp_unexpected_fun_app (prependQualified m (text "do block")) a - ErrMDoInFunAppExpr m a + PsErrMDoInFunAppExpr m a -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a - ErrLambdaInFunAppExpr a + PsErrLambdaInFunAppExpr a -> pp_unexpected_fun_app (text "lambda expression") a - ErrCaseInFunAppExpr a + PsErrCaseInFunAppExpr a -> pp_unexpected_fun_app (text "case expression") a - ErrLambdaCaseInFunAppExpr a + PsErrLambdaCaseInFunAppExpr a -> pp_unexpected_fun_app (text "lambda-case expression") a - ErrLetInFunAppExpr a + PsErrLetInFunAppExpr a -> pp_unexpected_fun_app (text "let expression") a - ErrIfInFunAppExpr a + PsErrIfInFunAppExpr a -> pp_unexpected_fun_app (text "if expression") a - ErrProcInFunAppExpr a + PsErrProcInFunAppExpr a -> pp_unexpected_fun_app (text "proc expression") a - ErrMalformedTyOrClDecl ty + PsErrMalformedTyOrClDecl ty -> text "Malformed head of type or class declaration:" <+> ppr ty - ErrIllegalWhereInDataDecl + PsErrIllegalWhereInDataDecl -> vcat [ text "Illegal keyword 'where' in data declaration" , text "Perhaps you intended to use GADTs or a similar language" , text "extension to enable syntax: data T where" ] - ErrIllegalTraditionalRecordSyntax s + PsErrIllegalTraditionalRecordSyntax s -> text "Illegal record syntax (use TraditionalRecordSyntax):" <+> s - ErrParseErrorOnInput occ + PsErrParseErrorOnInput occ -> text "parse error on input" <+> ftext (occNameFS occ) - ErrIllegalDataTypeContext c + PsErrIllegalDataTypeContext c -> text "Illegal datatype context (use DatatypeContexts):" <+> pprLHsContext c - ErrMalformedDecl what for + PsErrMalformedDecl what for -> text "Malformed" <+> what <+> text "declaration for" <+> quotes (ppr for) - ErrUnexpectedTypeAppInDecl ki what for + PsErrUnexpectedTypeAppInDecl ki what for -> vcat [ text "Unexpected type application" <+> text "@" <> ppr ki , text "In the" <+> what @@ -433,35 +433,35 @@ pp_err = \case <+> quotes (ppr for) ] - ErrNotADataCon name + PsErrNotADataCon name -> text "Not a data constructor:" <+> quotes (ppr name) - ErrRecordSyntaxInPatSynDecl pat + PsErrRecordSyntaxInPatSynDecl pat -> text "record syntax not supported for pattern synonym declarations:" $$ ppr pat - ErrEmptyWhereInPatSynDecl patsyn_name + PsErrEmptyWhereInPatSynDecl patsyn_name -> text "pattern synonym 'where' clause cannot be empty" $$ text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) - ErrInvalidWhereBindInPatSynDecl patsyn_name decl + PsErrInvalidWhereBindInPatSynDecl 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 + PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl -> text "pattern synonym 'where' clause must contain a single binding:" $$ ppr decl - ErrDeclSpliceNotAtTopLevel d + PsErrDeclSpliceNotAtTopLevel d -> hang (text "Declaration splices are allowed only" <+> text "at the top level:") 2 (ppr d) - ErrInferredTypeVarNotAllowed + PsErrInferredTypeVarNotAllowed -> text "Inferred type variables are not allowed here" - ErrIllegalRoleName role nearby + PsErrIllegalRoleName role nearby -> text "Illegal role name" <+> quotes (ppr role) $$ case nearby of [] -> empty @@ -470,17 +470,17 @@ pp_err = \case _ -> hang (text "Perhaps you meant one of these:") 2 (pprWithCommas (quotes . ppr) nearby) - ErrMultipleNamesInStandaloneKindSignature vs + PsErrMultipleNamesInStandaloneKindSignature vs -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") 2 (pprWithCommas ppr vs) , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] - ErrIllegalImportBundleForm + PsErrIllegalImportBundleForm -> text "Illegal import form, this syntax can only be used to bundle" $+$ text "pattern synonyms with types in module exports." - ErrInvalidTypeSignature lhs + PsErrInvalidTypeSignature lhs -> text "Invalid type signature:" <+> ppr lhs <+> text ":: ..." @@ -507,7 +507,7 @@ pp_err = \case default_RDR = mkUnqual varName (fsLit "default") pattern_RDR = mkUnqual varName (fsLit "pattern") - ErrUnexpectedTypeInDecl t what tc tparms equals_or_where + PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where -> vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> what <+> ptext (sLit "declaration for") <+> quotes tc' @@ -524,20 +524,20 @@ pp_err = \case -- wrote). See #14907 tc' = ppr $ filterCTuple tc - ErrCmmParser cmm_err -> case cmm_err of + PsErrCmmParser cmm_err -> case cmm_err of CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint - ErrExpectedHyphen + PsErrExpectedHyphen -> text "Expected a hyphen" - ErrSpaceInSCC + PsErrSpaceInSCC -> text "Spaces are not allowed in SCCs" - ErrEmptyDoubleQuotes th_on + PsErrEmptyDoubleQuotes th_on -> if th_on then vcat (msg ++ th_msg) else vcat msg where msg = [ text "Parser error on `''`" @@ -547,23 +547,23 @@ pp_err = \case , text "but the type variable or constructor is missing" ] - ErrInvalidPackageName pkg + PsErrInvalidPackageName pkg -> vcat [ text "Parse error" <> colon <+> quotes (ftext pkg) , text "Version number or non-alphanumeric" <+> text "character in package name" ] - ErrInvalidRuleActivationMarker + PsErrInvalidRuleActivationMarker -> text "Invalid rule activation marker" - ErrLinearFunction + PsErrLinearFunction -> text "Enable LinearTypes to allow linear functions" - ErrMultiWayIf + PsErrMultiWayIf -> text "Multi-way if-expressions need MultiWayIf turned on" - ErrExplicitForall is_unicode + PsErrExplicitForall is_unicode -> vcat [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type" , text "Perhaps you intended to use RankNTypes or a similar language" @@ -574,7 +574,7 @@ pp_err = \case forallSym True = text "∀" forallSym False = text "forall" - ErrIllegalQualifiedDo qdoDoc + PsErrIllegalQualifiedDo qdoDoc -> vcat [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block" , text "Perhaps you intended to use QualifiedDo" diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index fdf854ad8e..4e2c297bea 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -73,7 +73,7 @@ getImports :: ParserOpts -- ^ Parser options -> FilePath -- ^ The original source filename (used for locations -- in the function result) -> IO (Either - (Bag Error) + (Bag PsError) ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName)) diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 4d7b1ab157..a3f082f4c9 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -353,7 +353,7 @@ $tab { warnTab } } <0,option_prags> { - "{-#" { warnThen Opt_WarnUnrecognisedPragmas WarnUnrecognisedPragma + "{-#" { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma (nested_comment lexToken) } } @@ -1103,7 +1103,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 $ Error ErrMissingBlock [] (mkSrcSpanPs span) + else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span) pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -1482,7 +1482,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) (Error (ErrLexer LexUnterminatedComment LexErrKind_EOF) []) +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) []) open_brace, close_brace :: Action open_brace span _str _len = do @@ -1541,7 +1541,7 @@ varid span buf len = lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState - addError $ Error ErrLambdaCase [] (mkSrcSpanPs (last_loc pState)) + addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState)) return ITlcase _ -> return ITcase maybe_layout keyword @@ -1574,7 +1574,7 @@ varsym_prefix :: Action varsym_prefix = sym $ \span exts s -> let warnExtConflict errtok = do { addWarning Opt_WarnOperatorWhitespaceExtConflict $ - WarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok + PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok ; return (ITvarsym s) } in if | s == fsLit "@" -> @@ -1598,17 +1598,17 @@ varsym_prefix = sym $ \span exts s -> | s == fsLit "~" -> return ITtilde | otherwise -> do { addWarning Opt_WarnOperatorWhitespace $ - WarnOperatorWhitespace (mkSrcSpanPs span) s + PsWarnOperatorWhitespace (mkSrcSpanPs span) s OperatorWhitespaceOccurrence_Prefix ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action varsym_suffix = sym $ \span _ s -> - if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT []) + if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT []) | otherwise -> do { addWarning Opt_WarnOperatorWhitespace $ - WarnOperatorWhitespace (mkSrcSpanPs span) s + PsWarnOperatorWhitespace (mkSrcSpanPs span) s OperatorWhitespaceOccurrence_Suffix ; return (ITvarsym s) } @@ -1618,7 +1618,7 @@ varsym_tight_infix = sym $ \span _ s -> if | s == fsLit "@" -> return ITat | otherwise -> do { addWarning Opt_WarnOperatorWhitespace $ - WarnOperatorWhitespace (mkSrcSpanPs span) s + PsWarnOperatorWhitespace (mkSrcSpanPs span) s OperatorWhitespaceOccurrence_TightInfix ; return (ITvarsym s) } @@ -1666,7 +1666,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 $ Error (ErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState)) + addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState)) return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int @@ -1707,7 +1707,7 @@ tok_frac drop f span buf len = do let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError $ Error (ErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState)) + addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState)) return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token @@ -1877,7 +1877,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) (Error (ErrLexer LexUnterminatedOptions LexErrKind_EOF) []) + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) []) -- ----------------------------------------------------------------------------- @@ -1915,7 +1915,7 @@ lex_string s = do setInput i when (any (> '\xFF') s') $ do pState <- getPState - let err = Error ErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState)) + let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState)) addError err return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> @@ -2178,7 +2178,7 @@ quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput reportLexError start (psRealLoc end) buf - (\k -> Error (ErrLexer LexUnterminatedQQ k) []) + (\k -> PsError (PsErrLexer LexUnterminatedQQ k) []) -- ----------------------------------------------------------------------------- -- Warnings @@ -2188,7 +2188,7 @@ warnTab srcspan _buf _len = do addTabWarning (psRealSpan srcspan) lexToken -warnThen :: WarningFlag -> (SrcSpan -> Warning) -> Action -> Action +warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action warnThen flag warning action srcspan buf len = do addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing)) action srcspan buf len @@ -2248,8 +2248,8 @@ data HdkComment data PState = PState { buffer :: StringBuffer, options :: ParserOpts, - warnings :: Bag Warning, - errors :: Bag Error, + warnings :: Bag PsWarning, + errors :: Bag PsError, tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Word, -- number of tab warnings in the file last_tk :: Maybe Token, @@ -2329,12 +2329,12 @@ thenP :: P a -> (a -> P b) -> P b POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> Error) -> P a +failMsgP :: (SrcSpan -> PsError) -> P a failMsgP f = do pState <- getPState addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> Error) -> P a +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a failLocMsgP loc1 loc2 f = addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing)) @@ -2786,15 +2786,15 @@ class Monad m => MonadP m where -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. -- - addError :: Error -> m () + addError :: PsError -> m () -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings. - addWarning :: WarningFlag -> Warning -> m () + addWarning :: WarningFlag -> PsWarning -> 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 :: Error -> m a + addFatalError :: PsError -> m a -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool @@ -2840,19 +2840,19 @@ addTabWarning srcspan -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account. -getErrorMessages :: PState -> Bag Error +getErrorMessages :: PState -> Bag PsError getErrorMessages p = errors p -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account. -getMessages :: PState -> (Bag Warning, Bag Error) +getMessages :: PState -> (Bag PsWarning, Bag PsError) 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) + Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p) `consBag` ws in (ws', errors p) @@ -2900,8 +2900,8 @@ srcParseErr -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token -> SrcSpan - -> Error -srcParseErr options buf len loc = Error (ErrParse token) suggests loc + -> PsError +srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc where token = lexemeToString (offsetBytes (-len) buf) len pattern = decodePrevNChars 8 buf @@ -2936,7 +2936,7 @@ lexError e = do loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc (psRealLoc end) buf - (\k -> Error (ErrLexer e k) []) + (\k -> PsError (PsErrLexer e k) []) -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a @@ -3052,7 +3052,7 @@ alternativeLayoutRuleToken t (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where + $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3062,7 +3062,7 @@ alternativeLayoutRuleToken t (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe + $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3184,7 +3184,7 @@ lexToken = do return (L span ITeof) AlexError (AI loc2 buf) -> reportLexError (psRealLoc loc1) (psRealLoc loc2) buf - (\k -> Error (ErrLexer LexError k) []) + (\k -> PsError (PsErrLexer LexError k) []) AlexSkip inp2 _ -> do setInput inp2 lexToken @@ -3198,7 +3198,7 @@ lexToken = do unless (isComment lt') (setLastTk lt') return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> Error) -> P a +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a reportLexError loc1 loc2 buf f | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) | otherwise = diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index a59e4a882f..6071956e1b 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -260,12 +260,12 @@ mkStandaloneKindSig loc lhs rhs = check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v - else addFatalError $ Error (ErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v) + else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v - _ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) + _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) mkTyFamInstEqn :: HsOuterFamEqnTyVarBndrs GhcPs -> LHsType GhcPs @@ -374,7 +374,7 @@ mkRoleAnnotDecl loc tycon roles let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in - addFatalError $ Error (ErrIllegalRoleName role nearby) [] loc_role + addFatalError $ PsError (PsErrIllegalRoleName 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 @@ -394,7 +394,7 @@ fromSpecTyVarBndr bndr = case bndr of where check_spec :: Specificity -> SrcSpan -> P () check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ Error ErrInferredTypeVarNotAllowed [] loc + check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] loc {- ********************************************************************** @@ -445,7 +445,7 @@ cvBindsAndSigs fb = do -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ Error (ErrDeclSpliceNotAtTopLevel d) [] l + addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] l drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -550,14 +550,14 @@ constructor, a type, or a context, we would need unlimited lookahead which -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] -tyConToDataCon :: SrcSpan -> RdrName -> Either Error (Located RdrName) +tyConToDataCon :: SrcSpan -> RdrName -> Either PsError (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = Left $ Error (ErrNotADataCon tc) [] loc + = Left $ PsError (PsErrNotADataCon tc) [] loc where occ = rdrNameOcc tc @@ -597,17 +597,17 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = fromDecl (L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = - addFatalError $ Error (ErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc wrongNameBindingErr loc decl = - addFatalError $ Error (ErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc wrongNumberErr loc = - addFatalError $ Error (ErrEmptyWhereInPatSynDecl patsyn_name) [] loc + addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = - addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc + addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs @@ -737,7 +737,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} -eitherToP :: MonadP m => Either Error a -> m a +eitherToP :: MonadP m => Either PsError a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing @@ -751,9 +751,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 $ Error (ErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc + check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc check (HsValArg ty) = chkParens [] ty - check (HsArgPar sp) = addFatalError $ Error (ErrMalformedDecl pp_what (unLoc tc)) [] sp + check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) @@ -769,7 +769,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 $ Error (ErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc + = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc whereDots, equalsDots :: SDoc @@ -781,7 +781,7 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ Error (ErrIllegalDataTypeContext c) [] (getLoc c) + unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLoc c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) @@ -811,13 +811,13 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc) + (addFatalError $ PsError (PsErrParseErrorOnInput 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 $ Error (ErrIllegalTraditionalRecordSyntax (ppr r)) [] loc + unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] loc return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for @@ -826,7 +826,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 $ Error ErrIllegalWhereInDataDecl [] span + unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. @@ -848,7 +848,7 @@ checkTyClHdr is_cls ty -- workaround to define '*' despite StarIsType go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix - = do { addWarning Opt_WarnStarBinder (WarnStarBinder l) + = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder l) ; let name = mkOccName tcClsName (starSym isUni) ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } @@ -867,7 +867,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 $ Error (ErrMalformedTyOrClDecl ty) [] l + = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. @@ -877,29 +877,29 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () where checkExpr :: LHsExpr GhcPs -> PV () checkExpr expr = case unLoc expr of - 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 + HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr + HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr + HsLam {} -> check PsErrLambdaInFunAppExpr expr + HsCase {} -> check PsErrCaseInFunAppExpr expr + HsLamCase {} -> check PsErrLambdaCaseInFunAppExpr expr + HsLet {} -> check PsErrLetInFunAppExpr expr + HsIf {} -> check PsErrIfInFunAppExpr expr + HsProc {} -> check PsErrProcInFunAppExpr expr _ -> return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd cmd = case unLoc cmd of - HsCmdLam {} -> check ErrLambdaCmdInFunAppCmd cmd - HsCmdCase {} -> check ErrCaseCmdInFunAppCmd cmd - HsCmdIf {} -> check ErrIfCmdInFunAppCmd cmd - HsCmdLet {} -> check ErrLetCmdInFunAppCmd cmd - HsCmdDo {} -> check ErrDoCmdInFunAppCmd cmd + HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd + HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd + HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd + HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd + HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd _ -> return () check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ - addError $ Error (err a) [] (getLoc a) + addError $ PsError (err a) [] (getLoc a) -- | Validate the context constraints and break up a context into a list -- of predicates. @@ -1014,7 +1014,7 @@ checkAPat loc e0 = do -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do - addError $ Error ErrAtInPatPos [] (getLoc op) + addError $ PsError PsErrAtInPatPos [] (getLoc op) return (WildPat noExtField) PatBuilderOpApp l (L cl c) r @@ -1046,7 +1046,7 @@ checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (L l (fld { hsRecFieldArg = p })) patFail :: SrcSpan -> SDoc -> PV a -patFail loc e = addFatalError $ Error (ErrParseErrorInPat e) [] loc +patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") @@ -1138,11 +1138,11 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) = return lrdr checkValSigLhs lhs@(L l _) - = addFatalError $ Error (ErrInvalidTypeSignature lhs) [] l + = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] l checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) - => (a -> Bool -> b -> Bool -> c -> ErrorDesc) + => (a -> Bool -> b -> Bool -> c -> PsErrorDesc) -> Located a -> Bool -> Located b -> Bool -> Located c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do @@ -1152,7 +1152,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr semiElse (unLoc elseExpr) loc = combineLocs guardExpr elseExpr - unless doAndIfThenElse $ addError (Error e [] loc) + unless doAndIfThenElse $ addError (PsError e [] loc) | otherwise = return () isFunLhs :: Located (PatBuilder GhcPs) @@ -1259,7 +1259,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 $ Error ErrInvalidInfixHole [] l + mkHsInfixHolePV l = addFatalError $ PsError PsErrInvalidInfixHole [] 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. @@ -1415,10 +1415,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 ErrSemiColonsInCondCmd c semi1 a semi2 b + checkDoAndIfThenElse PsErrSemiColonsInCondCmd 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) _ = addFatalError $ Error (ErrQualifiedDoInCmd m) [] l + mkHsDoPV l (Just m) _ = addFatalError $ PsError (PsErrQualifiedDoInCmd 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) @@ -1447,12 +1447,12 @@ instance DisambECP (HsCmd GhcPs) where rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a -cmdFail loc e = addFatalError $ Error (ErrParseErrorInCmd e) [] loc +cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do - addError $ Error (ErrArrowCmdInExpr c) [] l + addError $ PsError (PsErrArrowCmdInExpr c) [] l return (L l hsHoleExpr) ecpFromExp' = return mkHsLamPV l mg = return $ L l (HsLam noExtField mg) @@ -1473,7 +1473,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 ErrSemiColonsInCondExpr c semi1 a semi2 b + checkDoAndIfThenElse PsErrSemiColonsInCondExpr 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) @@ -1489,19 +1489,19 @@ 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 = addError (Error (ErrViewPatInExpr a b) [] l) + mkHsViewPatPV l a b = addError (PsError (PsErrViewPatInExpr a b) [] l) >> return (L l hsHoleExpr) - mkHsAsPatPV l v e = addError (Error (ErrTypeAppWithoutSpace (unLoc v) e) [] l) + mkHsAsPatPV l v e = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) >> return (L l hsHoleExpr) - mkHsLazyPatPV l e = addError (Error (ErrLazyPatWithoutSpace e) [] l) + mkHsLazyPatPV l e = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) >> return (L l hsHoleExpr) - mkHsBangPatPV l e = addError (Error (ErrBangPatWithoutSpace e) [] l) + mkHsBangPatPV l e = addError (PsError (PsErrBangPatWithoutSpace 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 $ Error (ErrUnallowedPragma prag) [] l + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] l rejectPragmaPV _ = return () hsHoleExpr :: HsExpr GhcPs @@ -1509,21 +1509,21 @@ hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - 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 + ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] l + ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] l + mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l + mkHsLetPV l _ _ = addFatalError $ PsError PsErrLetInPat [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 - mkHsCasePV l _ _ = addFatalError $ Error ErrCaseInPat [] l - mkHsLamCasePV l _ = addFatalError $ Error ErrLambdaCaseInPat [] l + mkHsCasePV l _ _ = addFatalError $ PsError PsErrCaseInPat [] l + mkHsLamCasePV l _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) mkHsAppTypePV l p t = return $ L l (PatBuilderAppType p (mkHsPatSigType t)) - mkHsIfPV l _ _ _ _ _ = addFatalError $ Error ErrIfTheElseInPat [] l - mkHsDoPV l _ _ = addFatalError $ Error ErrDoNotationInPat [] l + mkHsIfPV l _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l + mkHsDoPV l _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l mkHsParPV l p = return $ L l (PatBuilderPar p) mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) mkHsLitPV lit@(L l a) = do @@ -1568,7 +1568,7 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 - -> addFatalError $ Error (ErrIllegalUnboxedStringInPat lit) [] loc + -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc _ -> return () mkPatRec :: @@ -1584,7 +1584,7 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) , pat_args = RecCon (HsRecFields fs dd) } mkPatRec p _ = - addFatalError $ Error (ErrInvalidRecordCon (unLoc p)) [] (getLoc p) + addFatalError $ PsError (PsErrInvalidRecordCon (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. @@ -1648,7 +1648,7 @@ instance DisambTD DataConBuilder where panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs l_at ki = - addFatalError $ Error (ErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at + addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (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 @@ -1658,7 +1658,7 @@ instance DisambTD DataConBuilder where l = combineLocs lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) = - addError $ Error (ErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l + addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff @@ -1669,7 +1669,7 @@ instance DisambTD DataConBuilder where let l = combineLocs unpk constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise = - do addError $ Error ErrUnpackDataCon [] (getLoc unpk) + do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk) return constr_stuff tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder) @@ -1680,7 +1680,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 $ Error (ErrInvalidDataCon (unLoc t)) [] (getLoc t) + addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLoc t) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2129,7 +2129,7 @@ checkPrecP checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () - | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l + | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l where -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR @@ -2145,7 +2145,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 $ Error ErrDotsInRecordUpdate [] dd_loc + | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs @@ -2209,7 +2209,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 $ Error ErrMalformedEntityString [] loc + Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in @@ -2347,12 +2347,12 @@ mkModuleImpExp (L l specname) subs = in (\newName -> IEThingWith noExtField (L l newName) pos ies []) <$> nameT - else addFatalError $ Error ErrIllegalPatSynExport [] l + else addFatalError $ PsError PsErrIllegalPatSynExport [] l where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then addFatalError $ Error (ErrVarForTyCon name) [] l + then addFatalError $ PsError (PsErrVarForTyCon name) [] l else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln @@ -2369,7 +2369,7 @@ mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ Error ErrIllegalExplicitNamespace [] (getLoc name) + unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLoc name) return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) @@ -2379,7 +2379,7 @@ checkImportSpec ie@(L _ specs) = (l:_) -> importSpecError l where importSpecError l = - addFatalError $ Error ErrIllegalImportBundleForm [] l + addFatalError $ PsError PsErrIllegalImportBundleForm [] l -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) @@ -2400,21 +2400,21 @@ isImpExpQcWildcard _ = False warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span = - addWarning Opt_WarnPrepositiveQualifiedModule (WarnImportPreQualified span) + addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span) failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = addError $ Error ErrImportPostQualified [] loc +failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = addError $ Error ErrImportQualifiedTwice [] loc +failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc warnStarIsType :: SrcSpan -> P () -warnStarIsType span = addWarning Opt_WarnStarIsType (WarnStarIsType span) +warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span) failOpFewArgs :: MonadP m => Located RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit - ; addFatalError $ Error (ErrOpFewArgs (StarIsType star_is_type) op) [] loc } + ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] loc } ----------------------------------------------------------------------------- -- Misc utils @@ -2427,8 +2427,8 @@ data PV_Context = data PV_Accum = PV_Accum - { pv_warnings :: Bag Warning - , pv_errors :: Bag Error + { pv_warnings :: Bag PsWarning + , pv_errors :: Bag PsError , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])] , pv_comment_q :: [RealLocated AnnotationComment] , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] @@ -2503,10 +2503,10 @@ add_hint hint m = PV (\ctx acc -> unPV m (modifyHint ctx) acc) instance MonadP PV where - addError err@(Error e hints loc) = + addError err@(PsError e hints loc) = PV $ \ctx acc -> let err' | null (pv_hints ctx) = err - | otherwise = Error e (hints ++ pv_hints ctx) loc + | otherwise = PsError e (hints ++ pv_hints ctx) loc in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} () addWarning option w = PV $ \ctx acc -> @@ -2580,7 +2580,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ - addError $ Error (ErrIllegalBangPattern e) [] span + addError $ PsError (PsErrIllegalBangPattern e) [] span mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) @@ -2595,7 +2595,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 $ Error (ErrUnsupportedBoxedSumExpr a) [] l + addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] l mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) @@ -2606,7 +2606,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 $ Error ErrTupleSectionInPat [] l + Nothing -> addFatalError $ PsError PsErrTupleSectionInPat [] l Just p' -> checkLPat p' -- Sum @@ -2614,7 +2614,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 $ Error (ErrUnsupportedBoxedSumPat a) [] l + addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] l mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index f291830ea2..3e1e171da3 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -192,9 +192,9 @@ addHaddockToModule lmod = do reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) = - addWarning Opt_WarnInvalidHaddock $ WarnHaddockInvalidPos (mkSrcSpanPs l) + addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l) reportHdkWarning (HdkWarnExtraComment (L l _)) = - addWarning Opt_WarnInvalidHaddock $ WarnHaddockIgnoreMulti l + addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } = |