diff options
| author | Aaron Allen <aaron@flipstone.com> | 2022-10-24 17:11:21 +0200 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2022-10-24 17:11:21 +0200 |
| commit | 0614e74ddd17d0a498d081bb3533cec2a2093c1c (patch) | |
| tree | faa1a3ff28aea038ebc796c2de47e01992f136f9 | |
| parent | f0a90c117ac598504ccb6514de77355de7415c86 (diff) | |
| download | haskell-0614e74ddd17d0a498d081bb3533cec2a2093c1c.tar.gz | |
Convert Diagnostics in GHC.Tc.Gen.Splice (#20116)
Replaces uses of `TcRnUnknownMessage` in `GHC.Tc.Gen.Splice` with
structured diagnostics.
closes #20116
58 files changed, 717 insertions, 237 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 0c152b27b7..84338000b9 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -96,6 +97,7 @@ import Data.List ( groupBy, sortBy, tails import Data.Ord ( comparing ) import Data.Bifunctor import GHC.Types.Name.Env +import qualified Language.Haskell.TH as TH data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not } @@ -1046,6 +1048,108 @@ instance Diagnostic TcRnMessage where sneaky_eq_spec = any (\eq -> any (( == eqSpecTyVar eq) . binderVar) invisible_binders) $ dataConEqSpec con + TcRnTypedTHWithPolyType ty + -> mkSimpleDecorated $ + vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + TcRnSpliceThrewException phase _exn exn_msg expr show_code + -> mkSimpleDecorated $ + vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:" + , nest 2 (text exn_msg) + , if show_code then text "Code:" <+> ppr expr else empty] + where phaseStr = + case phase of + SplicePhase_Run -> "run" + SplicePhase_CompileAndLink -> "compile and link" + TcRnInvalidTopDecl _decl + -> mkSimpleDecorated $ + text "Only function, value, annotation, and foreign import declarations may be added with addTopDecls" + TcRnNonExactName name + -> mkSimpleDecorated $ + hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + TcRnAddInvalidCorePlugin plugin + -> mkSimpleDecorated $ + hang + (text "addCorePlugin: invalid plugin module " + <+> text (show plugin) + ) + 2 + (text "Plugins in the current package can't be specified.") + TcRnAddDocToNonLocalDefn doc_loc + -> mkSimpleDecorated $ + text "Can't add documentation to" <+> ppr_loc doc_loc <+> + text "as it isn't inside the current module" + where + ppr_loc (TH.DeclDoc n) = text $ TH.pprint n + ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n + ppr_loc (TH.InstDoc t) = text $ TH.pprint t + ppr_loc TH.ModuleDoc = text "the module header" + + TcRnFailedToLookupThInstName th_type reason + -> mkSimpleDecorated $ + case reason of + NoMatchesFound -> + text "Couldn't find any instances of" + <+> text (TH.pprint th_type) + <+> text "to add documentation to" + CouldNotDetermineInstance -> + text "Couldn't work out what instance" + <+> text (TH.pprint th_type) + <+> text "is supposed to be" + TcRnCannotReifyInstance ty + -> mkSimpleDecorated $ + hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application") + TcRnCannotReifyOutOfScopeThing th_name + -> mkSimpleDecorated $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + TcRnCannotReifyThingNotInTypeEnv name + -> mkSimpleDecorated $ + quotes (ppr name) <+> text "is not in the type environment at a reify" + TcRnNoRolesAssociatedWithThing thing + -> mkSimpleDecorated $ + text "No roles associated with" <+> (ppr thing) + TcRnCannotRepresentType sort ty + -> mkSimpleDecorated $ + hsep [text "Can't represent" <+> sort_doc <+> + text "in Template Haskell:", + nest 2 (ppr ty)] + where + sort_doc = text $ + case sort of + LinearInvisibleArgument -> "linear invisible argument" + CoercionsInTypes -> "coercions in types" + TcRnRunSpliceFailure mCallingFnName (ConversionFail what reason) + -> mkSimpleDecorated + . addCallingFn + . addSpliceInfo + $ pprConversionFailReason reason + where + addCallingFn rest = + case mCallingFnName of + Nothing -> rest + Just callingFn -> + hang (text ("Error in a declaration passed to " ++ callingFn ++ ":")) + 2 rest + addSpliceInfo = case what of + ConvDec d -> addSliceInfo' "declaration" d + ConvExp e -> addSliceInfo' "expression" e + ConvPat p -> addSliceInfo' "pattern" p + ConvType t -> addSliceInfo' "type" t + addSliceInfo' what item reasonErr = reasonErr $$ descr + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + descr = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (TH.pprint item)) + TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg + TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc diagnosticReason = \case TcRnUnknownMessage m @@ -1382,6 +1486,36 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnIllegalNewtype{} -> ErrorWithoutFlag + TcRnTypedTHWithPolyType{} + -> ErrorWithoutFlag + TcRnSpliceThrewException{} + -> ErrorWithoutFlag + TcRnInvalidTopDecl{} + -> ErrorWithoutFlag + TcRnNonExactName{} + -> ErrorWithoutFlag + TcRnAddInvalidCorePlugin{} + -> ErrorWithoutFlag + TcRnAddDocToNonLocalDefn{} + -> ErrorWithoutFlag + TcRnFailedToLookupThInstName{} + -> ErrorWithoutFlag + TcRnCannotReifyInstance{} + -> ErrorWithoutFlag + TcRnCannotReifyOutOfScopeThing{} + -> ErrorWithoutFlag + TcRnCannotReifyThingNotInTypeEnv{} + -> ErrorWithoutFlag + TcRnNoRolesAssociatedWithThing{} + -> ErrorWithoutFlag + TcRnCannotRepresentType{} + -> ErrorWithoutFlag + TcRnRunSpliceFailure{} + -> ErrorWithoutFlag + TcRnReportCustomQuasiError isError _ + -> if isError then ErrorWithoutFlag else WarningWithoutFlag + TcRnInterfaceLookupError{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -1720,6 +1854,36 @@ instance Diagnostic TcRnMessage where -> noHints TcRnIllegalNewtype{} -> noHints + TcRnTypedTHWithPolyType{} + -> noHints + TcRnSpliceThrewException{} + -> noHints + TcRnInvalidTopDecl{} + -> noHints + TcRnNonExactName{} + -> noHints + TcRnAddInvalidCorePlugin{} + -> noHints + TcRnAddDocToNonLocalDefn{} + -> noHints + TcRnFailedToLookupThInstName{} + -> noHints + TcRnCannotReifyInstance{} + -> noHints + TcRnCannotReifyOutOfScopeThing{} + -> noHints + TcRnCannotReifyThingNotInTypeEnv{} + -> noHints + TcRnNoRolesAssociatedWithThing{} + -> noHints + TcRnCannotRepresentType{} + -> noHints + TcRnRunSpliceFailure{} + -> noHints + TcRnReportCustomQuasiError{} + -> noHints + TcRnInterfaceLookupError{} + -> noHints diagnosticCode = constructorCode @@ -3610,3 +3774,79 @@ pprHsDocContext (ConDeclCtx [name]) = text "the definition of data constructor" <+> quotes (ppr name) pprHsDocContext (ConDeclCtx names) = text "the definition of data constructors" <+> interpp'SP names + +pprConversionFailReason :: ConversionFailReason -> SDoc +pprConversionFailReason = \case + IllegalOccName ctxt_ns occ -> + text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) + SumAltArityExceeded alt arity -> + text "Sum alternative" <+> text (show alt) + <+> text "exceeds its arity," <+> text (show arity) + IllegalSumAlt alt -> + vcat [ text "Illegal sum alternative:" <+> text (show alt) + , nest 2 $ text "Sum alternatives must start from 1" ] + IllegalSumArity arity -> + vcat [ text "Illegal sum arity:" <+> text (show arity) + , nest 2 $ text "Sums must have an arity of at least 2" ] + MalformedType typeOrKind ty -> + text "Malformed " <> text ty_str <+> text (show ty) + where ty_str = case typeOrKind of + TypeLevel -> "type" + KindLevel -> "kind" + IllegalLastStatement do_or_lc stmt -> + vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon + , nest 2 $ ppr stmt + , text "(It should be an expression.)" ] + KindSigsOnlyAllowedOnGADTs -> + text "Kind signatures are only allowed on GADTs" + IllegalDeclaration declDescr bad_decls -> + sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon + , nest 2 bads ] + where + (what, bads) = case bad_decls of + IllegalDecls (NE.toList -> decls) -> + (text "declaration" <> plural decls, vcat $ map ppr decls) + IllegalFamDecls (NE.toList -> decls) -> + ( text "family declaration" <> plural decls, vcat $ map ppr decls) + descrDoc = text $ case declDescr of + InstanceDecl -> "an instance declaration" + WhereClause -> "a where clause" + LetBinding -> "a let expression" + LetExpression -> "a let expression" + ClssDecl -> "a class declaration" + CannotMixGADTConsWith98Cons -> + text "Cannot mix GADT constructors with Haskell 98" + <+> text "constructors" + EmptyStmtListInDoBlock -> + text "Empty stmt list in do-block" + NonVarInInfixExpr -> + text "Non-variable expression is not allowed in an infix expression" + MultiWayIfWithoutAlts -> + text "Multi-way if-expression with no alternatives" + CasesExprWithoutAlts -> + text "\\cases expression with no alternatives" + ImplicitParamsWithOtherBinds -> + text "Implicit parameters mixed with other bindings" + InvalidCCallImpent from -> + text (show from) <+> text "is not a valid ccall impent" + RecGadtNoCons -> + text "RecGadtC must have at least one constructor name" + GadtNoCons -> + text "GadtC must have at least one constructor name" + InvalidTypeInstanceHeader tys -> + text "Invalid type instance header:" + <+> text (show tys) + InvalidTyFamInstLHS lhs -> + text "Invalid type family instance LHS:" + <+> text (show lhs) + InvalidImplicitParamBinding -> + text "Implicit parameter binding only allowed in let or where" + DefaultDataInstDecl adts -> + (text "Default data instance declarations" + <+> text "are not allowed:") + $$ ppr adts + FunBindLacksEquations nm -> + text "Function binding for" + <+> quotes (text (TH.pprint nm)) + <+> text "has no equations" diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index fdf7c3d665..e3b3ade094 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -77,6 +77,14 @@ module GHC.Tc.Errors.Types ( , ExpectedBackends , ArgOrResult(..) , MatchArgsContext(..), MatchArgBadMatches(..) + , ConversionFailReason(..) + , UnrepresentableTypeDescr(..) + , LookupTHInstNameErrReason(..) + , SplicePhase(..) + , THDeclDescriptor(..) + , RunSpliceFailReason(..) + , ThingBeingConverted(..) + , IllegalDecls(..) ) where import GHC.Prelude @@ -95,6 +103,7 @@ import GHC.Types.Error import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.ForeignCall (CLabelString) import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) +import qualified GHC.Types.Name.Occurrence as OccName import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing) @@ -119,12 +128,14 @@ import GHC.Types.Basic import GHC.Utils.Misc (capitalise, filterOut) import qualified GHC.LanguageExtensions as LangExt import GHC.Data.FastString (FastString) +import GHC.Exception.Type (SomeException) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.List.NonEmpty as NE import Data.Typeable (Typeable) import GHC.Unit.Module.Warnings (WarningTxt) +import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics ( Generic ) @@ -2344,6 +2355,190 @@ data TcRnMessage where -} TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage + {-| TcRnTypedTHWithPolyType is an error that signifies the illegal use + of a polytype in a typed template haskell expression. + + Example(s): + bad :: (forall a. a -> a) -> () + bad = $$( [|| \_ -> () ||] ) + + Test cases: th/T11452 + -} + TcRnTypedTHWithPolyType :: !TcType -> TcRnMessage + + {-| TcRnSpliceThrewException is an error that occurrs when running a template + haskell splice throws an exception. + + Example(s): + + Test cases: annotations/should_fail/annfail12 + perf/compiler/MultiLayerModulesTH_Make + perf/compiler/MultiLayerModulesTH_OneShot + th/T10796b + th/T19470 + th/T19709d + th/T5358 + th/T5976 + th/T7276a + th/T8987 + th/TH_exn1 + th/TH_exn2 + th/TH_runIO + -} + TcRnSpliceThrewException + :: !SplicePhase + -> !SomeException + -> !String -- ^ Result of showing the exception (cannot be done safely outside IO) + -> !(LHsExpr GhcTc) + -> !Bool -- True <=> Print the expression + -> TcRnMessage + + {-| TcRnInvalidTopDecl is a template haskell error occurring when one of the 'Dec's passed to + 'addTopDecls' is not a function, value, annotation, or foreign import declaration. + + Example(s): + + Test cases: + -} + TcRnInvalidTopDecl :: !(HsDecl GhcPs) -> TcRnMessage + + {-| TcRnNonExactName is a template haskell error for when a declaration being + added is bound to a name that is not fully known. + + Example(s): + + Test cases: + -} + TcRnNonExactName :: !RdrName -> TcRnMessage + + {-| TcRnAddInvalidCorePlugin is a template haskell error indicating that a + core plugin being added has an invalid module due to being in the current package. + + Example(s): + + Test cases: + -} + TcRnAddInvalidCorePlugin + :: !String -- ^ Module name + -> TcRnMessage + + {-| TcRnAddDocToNonLocalDefn is a template haskell error for documentation being added to a + definition which is not in the current module. + + Example(s): + + Test cases: showIface/should_fail/THPutDocExternal + -} + TcRnAddDocToNonLocalDefn :: !TH.DocLoc -> TcRnMessage + + {-| TcRnFailedToLookupThInstName is a template haskell error that occurrs when looking up an + instance fails. + + Example(s): + + Test cases: showIface/should_fail/THPutDocNonExistent + -} + TcRnFailedToLookupThInstName :: !TH.Type -> !LookupTHInstNameErrReason -> TcRnMessage + + {-| TcRnCannotReifyInstance is a template haskell error for when an instance being reified + via `reifyInstances` is not a class constraint or type family application. + + Example(s): + + Test cases: + -} + TcRnCannotReifyInstance :: !Type -> TcRnMessage + + {-| TcRnCannotReifyOutOfScopeThing is a template haskell error indicating + that the given name is not in scope and therefore cannot be reified. + + Example(s): + + Test cases: th/T16976f + -} + TcRnCannotReifyOutOfScopeThing :: !TH.Name -> TcRnMessage + + {-| TcRnCannotReifyThingNotInTypeEnv is a template haskell error occurring + when the given name is not in the type environment and therefore cannot be reified. + + Example(s): + + Test cases: + -} + TcRnCannotReifyThingNotInTypeEnv :: !Name -> TcRnMessage + + {-| TcRnNoRolesAssociatedWithName is a template haskell error for when the user + tries to reify the roles of a given name but it is not something that has + roles associated with it. + + Example(s): + + Test cases: + -} + TcRnNoRolesAssociatedWithThing :: !TcTyThing -> TcRnMessage + + {-| TcRnCannotRepresentThing is a template haskell error indicating that a + type cannot be reified because it does not have a representation in template haskell. + + Example(s): + + Test cases: + -} + TcRnCannotRepresentType :: !UnrepresentableTypeDescr -> !Type -> TcRnMessage + + {-| TcRnRunSpliceFailure is an error indicating that a template haskell splice + failed to be converted into a valid expression. + + Example(s): + + Test cases: th/T10828a + th/T10828b + th/T12478_4 + th/T15270A + th/T15270B + th/T16895a + th/T16895b + th/T16895c + th/T16895d + th/T16895e + th/T17379a + th/T17379b + th/T18740d + th/T2597b + th/T2674 + th/T3395 + th/T7484 + th/T7667a + th/TH_implicitParamsErr1 + th/TH_implicitParamsErr2 + th/TH_implicitParamsErr3 + th/TH_invalid_add_top_decl + -} + TcRnRunSpliceFailure + :: !(Maybe String) -- ^ Name of the function used to run the splice + -> !RunSpliceFailReason + -> TcRnMessage + + {-| TcRnUserErrReported is an error or warning thrown using 'qReport' from + the 'Quasi' instance of 'TcM'. + + Example(s): + + Test cases: + -} + TcRnReportCustomQuasiError + :: !Bool -- True => Error, False => Warning + -> !String -- Error body + -> TcRnMessage + + {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file. + + Example(s): + + Test cases: + -} + TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -2361,6 +2556,55 @@ instance Outputable TypeDataForbids where ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" +data RunSpliceFailReason + = ConversionFail !ThingBeingConverted !ConversionFailReason + deriving Generic + +-- | Identifies the TH splice attempting to be converted +data ThingBeingConverted + = ConvDec !TH.Dec + | ConvExp !TH.Exp + | ConvPat !TH.Pat + | ConvType !TH.Type + +-- | The reason a TH splice could not be converted to a Haskell expression +data ConversionFailReason + = IllegalOccName !OccName.NameSpace !String + | SumAltArityExceeded !TH.SumAlt !TH.SumArity + | IllegalSumAlt !TH.SumAlt + | IllegalSumArity !TH.SumArity + | MalformedType !TypeOrKind !TH.Type + | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs)) + | KindSigsOnlyAllowedOnGADTs + | IllegalDeclaration !THDeclDescriptor !IllegalDecls + | CannotMixGADTConsWith98Cons + | EmptyStmtListInDoBlock + | NonVarInInfixExpr + | MultiWayIfWithoutAlts + | CasesExprWithoutAlts + | ImplicitParamsWithOtherBinds + | InvalidCCallImpent !String -- ^ Source + | RecGadtNoCons + | GadtNoCons + | InvalidTypeInstanceHeader !TH.Type + | InvalidTyFamInstLHS !TH.Type + | InvalidImplicitParamBinding + | DefaultDataInstDecl ![LDataFamInstDecl GhcPs] + | FunBindLacksEquations !TH.Name + deriving Generic + +data IllegalDecls + = IllegalDecls !(NE.NonEmpty (LHsDecl GhcPs)) + | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs)) + +-- | Label for a TH declaration +data THDeclDescriptor + = InstanceDecl + | WhereClause + | LetBinding + | LetExpression + | ClssDecl + -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] @@ -3473,3 +3717,16 @@ data MatchArgBadMatches where :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } -> MatchArgBadMatches + +-- | The phase in which an exception was encountered when dealing with a TH splice +data SplicePhase + = SplicePhase_Run + | SplicePhase_CompileAndLink + +data LookupTHInstNameErrReason + = NoMatchesFound + | CouldNotDetermineInstance + +data UnrepresentableTypeDescr + = LinearInvisibleArgument + | CoercionsInTypes diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index f4490244f8..1ac3882d50 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -124,7 +124,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger -import GHC.Utils.Exception (throwIO, ErrorCall(..)) +import GHC.Utils.Exception (throwIO, ErrorCall(..), SomeException(..)) import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) @@ -794,16 +794,10 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) -- Takes a m and tau and returns the type m (TExp tau) tcTExpTy :: TcType -> TcType -> TcM TcType tcTExpTy m_ty exp_ty - = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) + = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType exp_ty) ; codeCon <- tcLookupTyCon codeTyConName ; let rep = getRuntimeRep exp_ty ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } - where - err_msg ty - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] quotationCtxtDoc :: LHsExpr GhcRn -> SDoc quotationCtxtDoc br_body @@ -1023,15 +1017,15 @@ runAnnotation target expr = do ann_value = serialized } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) +convertAnnotationWrapper :: ForeignHValue -> TcM Serialized convertAnnotationWrapper fhv = do interp <- tcGetInterp case interpInstance interp of - ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv + ExternalInterp {} -> runTH THAnnWrapper fhv #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do annotation_wrapper <- liftIO $ wormhole interp fhv - return $ Right $ + return $ case unsafeCoerce annotation_wrapper of AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> -- Got the value and dictionaries: build the serialized value and @@ -1118,7 +1112,7 @@ defaultRunMeta (MetaT r) defaultRunMeta (MetaD r) = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) + = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper) -- We turn off showing the code in meta-level exceptions because doing so exposes -- the toAnnotationWrapper function that we slap around the user's code @@ -1188,7 +1182,7 @@ Previously, we failed to abort in cases (b) and (c), leading to #19709. --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -- How to run x + -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or -- something like that -> TcM hs_syn -- Of type t @@ -1236,7 +1230,7 @@ runMeta' show_code ppr_hs run_and_convert expr ; either_hval <- tryM $ liftIO $ GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; + Left exn -> fail_with_exn SplicePhase_CompileAndLink exn ; Right (hval, needed_mods, needed_pkgs) -> do { -- Coerce it to Q t, and run it @@ -1257,7 +1251,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (TcRnRunSpliceFailure Nothing err) Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1265,17 +1259,15 @@ runMeta' show_code ppr_hs run_and_convert expr Right v -> return v Left se -> case fromException se of Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception + _ -> fail_with_exn SplicePhase_Run se -- Exception }}} where -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a + fail_with_exn :: Exception e => SplicePhase -> e -> TcM a fail_with_exn phase exn = do exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) + failWithTc + $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code {- Note [Running typed splices in the zonker] @@ -1391,9 +1383,8 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (text msg) - qReport False msg = seqList msg $ addDiagnostic $ mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (text msg) + qReport True msg = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg + qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg qLocation :: TcM TH.Loc qLocation = do { m <- getModule @@ -1446,9 +1437,8 @@ instance TH.Quasi TcM where th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Error in a declaration passed to addTopDecls:") - 2 exn + Left exn -> failWithTc + $ TcRnRunSpliceFailure (Just "addTopDecls") exn Right ds -> return ds mapM_ (checkTopDecl . unLoc) ds th_topdecls_var <- fmap tcg_th_topdecls getGblEnv @@ -1463,9 +1453,8 @@ instance TH.Quasi TcM where = return () checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name - checkTopDecl _ - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + checkTopDecl d + = addErr $ TcRnInvalidTopDecl d bindName :: RdrName -> TcM () bindName (Exact n) @@ -1473,10 +1462,7 @@ instance TH.Quasi TcM where ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) } - bindName name = - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + bindName name = addErr $ TcRnNonExactName name qAddForeignFilePath lang fp = do var <- fmap tcg_th_foreign_files getGblEnv @@ -1494,15 +1480,10 @@ instance TH.Quasi TcM where let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") + let err = TcRnAddInvalidCorePlugin plugin case r of - Found {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err - FoundMultiple {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err + Found {} -> addErr err + FoundMultiple {} -> addErr err _ -> return () th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) @@ -1527,9 +1508,7 @@ instance TH.Quasi TcM where th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text - "Can't add documentation to" <+> ppr_loc doc_loc <+> - text "as it isn't inside the current module" + unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc let ds = mkGeneratedHsDocString s hd = lexHsDoc parseIdentifier ds hd' <- rnHsDoc hd @@ -1540,11 +1519,6 @@ instance TH.Quasi TcM where resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t) resolve_loc TH.ModuleDoc = pure ModuleDoc - ppr_loc (TH.DeclDoc n) = ppr_th n - ppr_loc (TH.ArgDoc n _) = ppr_th n - ppr_loc (TH.InstDoc t) = ppr_th t - ppr_loc TH.ModuleDoc = text "the module header" - -- It doesn't make sense to add documentation to something not inside -- the current module. So check for it! checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n @@ -1617,10 +1591,8 @@ lookupThInstName th_type = do Right (_, (inst:_)) -> return $ getName inst Right (_, []) -> noMatches where - noMatches = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Couldn't find any instances of" - <+> ppr_th th_type - <+> text "to add documentation to" + noMatches = failWithTc $ + TcRnFailedToLookupThInstName th_type NoMatchesFound -- Get the name of the class for the instance we are documenting -- > inst_cls_name (Monad Maybe) == Monad @@ -1656,10 +1628,8 @@ lookupThInstName th_type = do inst_cls_name TH.WildCardT = inst_cls_name_err inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - inst_cls_name_err = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Couldn't work out what instance" - <+> ppr_th th_type - <+> text "is supposed to be" + inst_cls_name_err = failWithTc $ + TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance -- Basically does the opposite of 'mkThAppTs' -- > inst_arg_types (Monad Maybe) == [Maybe] @@ -1947,16 +1917,14 @@ reifyInstances' th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } + _ -> bale_out $ TcRnCannotReifyInstance ty } where doc = ClassInstanceCtx bale_out msg = failWithTc msg cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) + Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg) Right ty -> return ty {- @@ -2057,18 +2025,15 @@ tcLookupTh name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) + Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) }}}} notInScope :: TH.Name -> TcRnMessage -notInScope th_name = mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name +notInScope th_name = + TcRnCannotReifyOutOfScopeThing th_name notInEnv :: Name -> TcRnMessage -notInEnv name = mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is not in the type environment at a reify" +notInEnv name = TcRnCannotReifyThingNotInTypeEnv name ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -2076,7 +2041,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) + _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing) } where reify_role Nominal = TH.NominalR @@ -2609,11 +2574,11 @@ reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty) + | InvisArg <- af = noTH LinearInvisibleArgument ty | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty) +reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy @@ -2869,11 +2834,8 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hsep [text "Can't represent" <+> s <+> - text "in Template Haskell:", - nest 2 d]) +noTH :: UnrepresentableTypeDescr -> Type -> TcM a +noTH s d = failWithTc $ TcRnCannotRepresentType s d ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 4cba3f20b1..7e5f339d3f 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -170,7 +170,7 @@ checkHsigIface tcg_env gr sig_iface -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (mkTcRnUnknownMessage $ mkPlainError noHints err) + Failed err -> addErr (TcRnInterfaceLookupError name err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 5f73a56724..dec144f5bd 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -257,7 +257,7 @@ tcLookupGlobal name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) + Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 02ecec08fb..9f5badae49 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -33,6 +32,7 @@ import GHC.Prelude import GHC.Hs as Hs import GHC.Builtin.Names +import GHC.Tc.Errors.Types import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name import GHC.Unit.Module @@ -47,12 +47,10 @@ import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall import GHC.Types.Unique import GHC.Types.SourceText -import GHC.Utils.Error import GHC.Data.Bag import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString -import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -60,6 +58,8 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) import Control.Applicative( (<|>) ) +import Data.Bifunctor (first) +import Data.Foldable (for_) import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) @@ -71,30 +71,34 @@ import System.IO.Unsafe ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs] -convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) +convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs] +convertToHsDecls origin loc ds = + initCvt origin loc $ fmap catMaybes (mapM cvt_dec ds) where - cvt_dec d = wrapMsg "declaration" d (cvtDec d) + cvt_dec d = + wrapMsg (ConvDec d) $ cvtDec d -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs) +convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs) convertToHsExpr origin loc e - = initCvt origin loc $ wrapMsg "expression" e $ cvtl e + = initCvt origin loc $ wrapMsg (ConvExp e) $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs) +convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs) convertToPat origin loc p - = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p + = initCvt origin loc $ wrapMsg (ConvPat p) $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs) +convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs) convertToHsType origin loc t - = initCvt origin loc $ wrapMsg "type" t $ cvtType t + = initCvt origin loc $ wrapMsg (ConvType t) $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) } +newtype CvtM' err a = CvtM { unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) } deriving (Functor) -- Push down the Origin (that is configurable by -- -fenable-th-splice-warnings) and source location; -- Can fail, with a single error message +type CvtM = CvtM' ConversionFailReason + -- NB: If the conversion succeeds with (Right x), there should -- be no exception values hiding in x -- Reason: so a (head []) in TH code doesn't subsequently @@ -103,22 +107,25 @@ newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) -- Use the SrcSpan everywhere, for lack of anything better. -- See Note [Source locations within TH splices]. -instance Applicative CvtM where +instance Applicative (CvtM' err) where pure x = CvtM $ \_ loc -> Right (loc,x) (<*>) = ap -instance Monad CvtM where +instance Monad (CvtM' err) where (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of Left err -> Left err Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a +mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a +mapCvtMError f (CvtM m) = CvtM $ \origin loc -> first f $ m origin loc + +initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () -failWith :: SDoc -> CvtM a +failWith :: ConversionFailReason -> CvtM a failWith m = CvtM (\_ _ -> Left m) getOrigin :: CvtM Origin @@ -141,19 +148,8 @@ returnJustLA = fmap Just . returnLA wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) -wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b --- E.g wrapMsg "declaration" dec thing -wrapMsg what item (CvtM m) - = CvtM $ \origin loc -> case m origin loc of - Left err -> Left (err $$ msg) - Right v -> Right v - where - -- Show the item in pretty syntax normally, - -- but with all its constructors if you say -dppr-debug - msg = hang (text "When splicing a TH" <+> text what <> colon) - 2 (getPprDebug $ \case - True -> text (show item) - False -> text (pprint item)) +wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a +wrapMsg what = mapCvtMError (ConversionFail what) wrapL :: CvtM a -> CvtM (Located a) wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of @@ -220,7 +216,7 @@ cvtDec (TH.ValD pat body ds) | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") ds + ; ds' <- cvtLocalDecs WhereClause ds ; returnJustLA $ Hs.ValD noExtField $ PatBind { pat_lhs = pat' , pat_rhs = GRHSs emptyComments body' ds' @@ -229,9 +225,7 @@ cvtDec (TH.ValD pat body ds) cvtDec (TH.FunD nm cls) | null cls - = failWith (text "Function binding for" - <+> quotes (text (TH.pprint nm)) - <+> text "has no equations") + = failWith $ FunBindLacksEquations nm | otherwise = do { nm' <- vNameN nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls @@ -282,10 +276,9 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) isGadtDecl = all isGadtCon constrs isH98Decl = all (not . isGadtCon) constrs ; unless (isGadtDecl || isH98Decl) - (failWith (text "Cannot mix GADT constructors with Haskell 98" - <+> text "constructors")) + (failWith CannotMixGADTConsWith98Cons) ; unless (isNothing ksig || isGadtDecl) - (failWith (text "Kind signatures are only allowed on GADTs")) + (failWith KindSigsOnlyAllowedOnGADTs) ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs @@ -322,11 +315,9 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs + ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs ClssDecl decs ; unless (null adts') - (failWith $ (text "Default data instance declarations" - <+> text "are not allowed:") - $$ (Outputable.ppr adts')) + (failWith $ DefaultDataInstDecl adts') ; returnJustLA $ TyClD noExtField $ ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' @@ -338,9 +329,9 @@ cvtDec (ClassD ctxt cl tvs fds decs) } cvtDec (InstanceD o ctxt ty decs) - = do { let doc = text "an instance declaration" - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs - ; unless (null fams') (failWith (mkBadDecMsg doc fams')) + = do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs + ; for_ (nonEmpty fams') $ \ bad_fams -> + failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams) ; ctxt' <- cvtContext funPrec ctxt ; (L loc ty') <- cvtType ty ; let inst_ty' = L loc $ mkHsImplicitSigType $ @@ -490,7 +481,7 @@ cvtDec (TH.PatSynSigD nm ty) -- cvtImplicitParamBind. They are not allowed in any other scope, so -- reaching this case indicates an error. cvtDec (TH.ImplicitParamBindD _ _) - = failWith (text "Implicit parameter binding only allowed in let or where") + = failWith InvalidImplicitParamBinding ---------------- cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) @@ -520,12 +511,11 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) (map HsValArg args') ++ args , feqn_fixity = Hs.Infix , feqn_rhs = rhs' } } - _ -> failWith $ text "Invalid type family instance LHS:" - <+> text (show lhs) + _ -> failWith $ InvalidTyFamInstLHS lhs } ---------------- -cvt_ci_decs :: SDoc -> [TH.Dec] +cvt_ci_decs :: THDeclDescriptor -> [TH.Dec] -> CvtM (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], @@ -533,14 +523,15 @@ cvt_ci_decs :: SDoc -> [TH.Dec] [LDataFamInstDecl GhcPs]) -- Convert the declarations inside a class or instance decl -- ie signatures, bindings, and associated types -cvt_ci_decs doc decs +cvt_ci_decs declDescr decs = do { decs' <- cvtDecs decs ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' ; let (sigs', prob_binds') = partitionWith is_sig no_ats' ; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (fams', bads) = partitionWith is_fam_decl prob_fams' - ; unless (null bads) (failWith (mkBadDecMsg doc bads)) + ; for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- @@ -573,8 +564,7 @@ cvt_datainst_hdr cxt bndrs tys ; args' <- mapM cvtType [t1,t2] ; return (cxt', nm', outer_bndrs, ((map HsValArg args') ++ args)) } - _ -> failWith $ text "Invalid type instance header:" - <+> text (show tys) } + _ -> failWith $ InvalidTypeInstanceHeader tys } ---------------- cvt_tyfam_head :: TypeFamilyHead @@ -584,7 +574,7 @@ cvt_tyfam_head :: TypeFamilyHead , Maybe (Hs.LInjectivityAnn GhcPs)) cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) - = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars + = do { (_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars ; result' <- cvtFamilyResultSig result ; injectivity' <- traverse cvtInjectivityAnnotation injectivity ; return (tc', tyvars', result', injectivity') } @@ -622,11 +612,6 @@ is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) is_ip_bind decl = Right decl -mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc -mkBadDecMsg doc bads - = sep [ text "Illegal declaration(s) in" <+> doc <> colon - , nest 2 (vcat (map Outputable.ppr bads)) ] - --------------------------------------------------- -- Data types --------------------------------------------------- @@ -683,7 +668,7 @@ cvtConstr (ForallC tvs ctxt con) all_tvs = tvs' ++ ex_tvs cvtConstr (GadtC c strtys ty) = case nonEmpty c of - Nothing -> failWith (text "GadtC must have at least one constructor name") + Nothing -> failWith GadtNoCons Just c -> do { c' <- mapM cNameN c ; args <- mapM cvt_arg strtys @@ -691,7 +676,7 @@ cvtConstr (GadtC c strtys ty) = case nonEmpty c of ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} cvtConstr (RecGadtC c varstrtys ty) = case nonEmpty c of - Nothing -> failWith (text "RecGadtC must have at least one constructor name") + Nothing -> failWith RecGadtNoCons Just c -> do { c' <- mapM cNameN c ; ty' <- cvtType ty @@ -770,7 +755,7 @@ cvtForD (ImportF callconv safety from nm ty) = from (L l $ quotedSourceText from) -> mk_imp impspec | otherwise - -> failWith $ text (show from) <+> text "is not a valid ccall impent" } + -> failWith $ InvalidCCallImpent from } where mk_imp impspec = do { nm' <- vNameN nm @@ -939,21 +924,22 @@ cvtRuleBndr (TypedRuleVar n ty) -- Declarations --------------------------------------------------- -cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) -cvtLocalDecs doc ds +cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs declDescr ds = case partitionWith is_ip_bind ds of ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds let (binds, prob_sigs) = partitionWith is_bind ds' let (sigs, bads) = partitionWith is_sig prob_sigs - unless (null bads) (failWith (mkBadDecMsg doc bads)) + for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> - failWith (text "Implicit parameters mixed with other bindings") + failWith ImplicitParamsWithOtherBinds cvtClause :: HsMatchContext GhcPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -961,7 +947,7 @@ cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ; let pps = map (parenthesizePat appPrec) ps' ; g' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") wheres + ; ds' <- cvtLocalDecs WhereClause wheres ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') } cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) @@ -1018,7 +1004,7 @@ cvtl e = wrapLA (cvt e) ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms' } cvt (LamCasesE ms) - | null ms = failWith (text "\\cases expression with no alternatives") + | null ms = failWith CasesExprWithoutAlts | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms ; th_origin <- getOrigin ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms' @@ -1031,10 +1017,10 @@ cvtl e = wrapLA (cvt e) cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ mkHsIf x' y' z' noAnn } cvt (MultiIfE alts) - | null alts = failWith (text "Multi-way if-expression with no alternatives") + | null alts = failWith MultiWayIfWithoutAlts | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf noAnn alts' } - cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds + cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin @@ -1129,8 +1115,7 @@ ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a ensureValidOpExp (VarE _n) m = m ensureValidOpExp (ConE _n) m = m ensureValidOpExp (UnboundVarE _n) m = m -ensureValidOpExp _e _m = - failWith (text "Non-variable expression is not allowed in an infix expression") +ensureValidOpExp _e _m = failWith NonVarInInfixExpr {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1243,7 +1228,7 @@ cvtOpApp x op y cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts - | null stmts = failWith (text "Empty stmt list in do-block") + | null stmts = failWith EmptyStmtListInDoBlock | otherwise = do { stmts' <- cvtStmts stmts ; let Just (stmts'', last') = snocView stmts' @@ -1255,9 +1240,7 @@ cvtHsDo do_or_lc stmts ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) } where - bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon - , nest 2 $ Outputable.ppr stmt - , text "(It should be an expression.)" ] + bad_last stmt = IllegalLastStatement do_or_lc stmt cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] cvtStmts = mapM cvtStmt @@ -1265,7 +1248,7 @@ cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnLA $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } -cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds +cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs LetBinding ds ; returnLA $ LetStmt noAnn ds' } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr } @@ -1284,7 +1267,7 @@ cvtMatch ctxt (TH.Match p body decs) (L loc SigPat{}) -> L loc (gParPat p') -- #14875 _ -> p' ; g' <- cvtGuard body - ; decs' <- cvtLocalDecs (text "a where clause") decs + ; decs' <- cvtLocalDecs WhereClause decs ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') } cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] @@ -1531,21 +1514,21 @@ cvtDerivStrategy (TH.ViaStrategy ty) = do returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) -cvtType = cvtTypeKind "type" +cvtType = cvtTypeKind TypeLevel cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs) -cvtSigType = cvtSigTypeKind "type" +cvtSigType = cvtSigTypeKind TypeLevel -- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating -- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform -- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'. -cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs) -cvtSigTypeKind ty_str ty = do - ty' <- cvtTypeKind ty_str ty +cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs) +cvtSigTypeKind typeOrKind ty = do + ty' <- cvtTypeKind typeOrKind ty pure $ hsTypeToHsSigType ty' -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) -cvtTypeKind ty_str ty +cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs) +cvtTypeKind typeOrKind ty = do { (head_ty, tys') <- split_ty_app ty ; let m_normals = mapM extract_normal tys' where extract_normal (HsValArg ty) = Just ty @@ -1568,10 +1551,7 @@ cvtTypeKind ty_str ty ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } UnboxedSumT n | n < 2 - -> failWith $ - vcat [ text "Illegal sum arity:" <+> text (show n) - , nest 2 $ - text "Sums must have an arity of at least 2" ] + -> failWith $ IllegalSumArity n | Just normals <- m_normals , normals `lengthIs` n -- Saturated -> returnLA (HsSumTy noAnn normals) @@ -1748,7 +1728,7 @@ cvtTypeKind ty_str ty ; returnLA (HsIParamTy noAnn (reLocA n') t') } - _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty)) + _ -> failWith (MalformedType typeOrKind ty) } hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs @@ -1859,10 +1839,10 @@ cvtOpAppT prom x op y ; returnLA (mkHsOpTy prom x' op y) } cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) -cvtKind = cvtTypeKind "kind" +cvtKind = cvtTypeKind KindLevel cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs) -cvtSigKind = cvtSigTypeKind "kind" +cvtSigKind = cvtSigTypeKind KindLevel -- | Convert Maybe Kind to a type family result signature. Used with data -- families where naming of the result is not possible (thus only kind or no @@ -1939,14 +1919,11 @@ overloadedLit _ = False unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () unboxedSumChecks alt arity | alt > arity - = failWith $ text "Sum alternative" <+> text (show alt) - <+> text "exceeds its arity," <+> text (show arity) + = failWith $ SumAltArityExceeded alt arity | alt <= 0 - = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) - , nest 2 $ text "Sum alternatives must start from 1" ] + = failWith $ IllegalSumAlt alt | arity < 2 - = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) - , nest 2 $ text "Sums must have an arity of at least 2" ] + = failWith $ IllegalSumArity arity | otherwise = return () @@ -2045,12 +2022,12 @@ tconName n = cvtName OccName.tcClsName n ipName :: String -> CvtM HsIPName ipName n - = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n)) + = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) ; return (HsIPName (fsLit n)) } cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName ctxt_ns (TH.Name occ flavour) - | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) + | not (okOcc ctxt_ns occ_str) = failWith (IllegalOccName ctxt_ns occ_str) | otherwise = do { loc <- getL ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour @@ -2073,11 +2050,6 @@ isVarName (TH.Name occ _) "" -> False (c:_) -> startsVarId c || startsVarSym c -badOcc :: OccName.NameSpace -> String -> SDoc -badOcc ctxt_ns occ - = text "Illegal" <+> pprNameSpace ctxt_ns - <+> text "name:" <+> quotes (text occ) - thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a TH Name into a RdrName; used for both binders and occurrences -- See Note [Binders in Template Haskell] diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 00346aa722..2e919ef61f 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -468,6 +468,22 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration" = 08585 GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 + GhcDiagnosticCode "TcRnTypedTHWithPolyType" = 94642 + GhcDiagnosticCode "TcRnSpliceThrewException" = 87897 + GhcDiagnosticCode "TcRnInvalidTopDecl" = 52886 + GhcDiagnosticCode "TcRnNonExactName" = 77923 + GhcDiagnosticCode "TcRnAddInvalidCorePlugin" = 86463 + GhcDiagnosticCode "TcRnAddDocToNonLocalDefn" = 67760 + GhcDiagnosticCode "TcRnFailedToLookupThInstName" = 49530 + GhcDiagnosticCode "TcRnCannotReifyInstance" = 30384 + GhcDiagnosticCode "TcRnCannotReifyOutOfScopeThing" = 24922 + GhcDiagnosticCode "TcRnCannotReifyThingNotInTypeEnv" = 79890 + GhcDiagnosticCode "TcRnNoRolesAssociatedWithThing" = 65923 + GhcDiagnosticCode "TcRnCannotRepresentType" = 75721 + GhcDiagnosticCode "TcRnReportCustomQuasiError" = 39584 + GhcDiagnosticCode "TcRnInterfaceLookupError" = 52243 + + -- IllegalNewtypeReason GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 GhcDiagnosticCode "IsNonLinear" = 38291 GhcDiagnosticCode "IsGADT" = 89498 @@ -479,6 +495,30 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 + -- TcRnRunSliceFailure/ConversionFail + GhcDiagnosticCode "IllegalOccName" = 55017 + GhcDiagnosticCode "SumAltArityExceeded" = 68444 + GhcDiagnosticCode "IllegalSumAlt" = 63966 + GhcDiagnosticCode "IllegalSumArity" = 97721 + GhcDiagnosticCode "MalformedType" = 28709 + GhcDiagnosticCode "IllegalLastStatement" = 47373 + GhcDiagnosticCode "KindSigsOnlyAllowedOnGADTs" = 40746 + GhcDiagnosticCode "IllegalDeclaration" = 23882 + GhcDiagnosticCode "CannotMixGADTConsWith98Cons" = 24104 + GhcDiagnosticCode "EmptyStmtListInDoBlock" = 34949 + GhcDiagnosticCode "NonVarInInfixExpr" = 99831 + GhcDiagnosticCode "MultiWayIfWithoutAlts" = 63930 + GhcDiagnosticCode "CasesExprWithoutAlts" = 91745 + GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974 + GhcDiagnosticCode "InvalidCCallImpent" = 60220 + GhcDiagnosticCode "RecGadtNoCons" = 18816 + GhcDiagnosticCode "GadtNoCons" = 38140 + GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056 + GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486 + GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 + GhcDiagnosticCode "DefaultDataInstDecl" = 39639 + GhcDiagnosticCode "FunBindLacksEquations" = 52078 + -- Diagnostic codes for the foreign function interface GhcDiagnosticCode "NotADataType" = 31136 GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 @@ -595,6 +635,12 @@ type family ConRecursInto con where ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason + -- + -- TH errors + + ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason + ConRecursInto "ConversionFail" = 'Just ConversionFailReason + ------------------ -- FFI errors diff --git a/testsuite/tests/annotations/should_fail/annfail12.stderr b/testsuite/tests/annotations/should_fail/annfail12.stderr index 303645914e..d9f2bbab77 100644 --- a/testsuite/tests/annotations/should_fail/annfail12.stderr +++ b/testsuite/tests/annotations/should_fail/annfail12.stderr @@ -1,5 +1,5 @@ -annfail12.hs:5:1: error: +annfail12.hs:5:1: error: [GHC-87897] Exception when trying to run compile-time code: You were meant to see this error! CallStack (from ImplicitParams): diff --git a/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr b/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr index 4a1b876638..bac52e7368 100644 --- a/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr +++ b/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr @@ -1,5 +1,5 @@ -MultiLayerModules.hs:334:8: error: +MultiLayerModules.hs:334:8: error: [GHC-87897] • Exception when trying to run compile-time code: deliberate error CallStack (from HasCallStack): diff --git a/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr b/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr index a958aceeea..c95319d9c2 100644 --- a/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr +++ b/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr @@ -1,5 +1,5 @@ -MultiLayerModulesTH_OneShot.hs:334:8: error: +MultiLayerModulesTH_OneShot.hs:334:8: error: [GHC-87897] • Exception when trying to run compile-time code: deliberate error CallStack (from HasCallStack): diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr index 3063fe9350..135a9faa82 100644 --- a/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr +++ b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr @@ -1,2 +1,3 @@ -THPutDocExternal.hs:8:1: + +THPutDocExternal.hs:8:1: error: [GHC-67760] Can't add documentation to THPutDocExternalA.f as it isn't inside the current module diff --git a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr index ce3a64a1d9..818d1312a7 100644 --- a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr +++ b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr @@ -1,2 +1,3 @@ -THPutDocNonExistent.hs:10:1: + +THPutDocNonExistent.hs:10:1: error: [GHC-49530] Couldn't find any instances of THPutDocNonExistent.A THPutDocNonExistent.B to add documentation to diff --git a/testsuite/tests/th/ClosedFam1TH.stderr b/testsuite/tests/th/ClosedFam1TH.stderr index 0ffa3428e7..bc00cc8eff 100644 --- a/testsuite/tests/th/ClosedFam1TH.stderr +++ b/testsuite/tests/th/ClosedFam1TH.stderr @@ -1,5 +1,5 @@ -ClosedFam1TH.hs:7:2: warning: +ClosedFam1TH.hs:7:2: warning: [GHC-39584] type family Foo_0 a_1 (b_2 :: k_3) where Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int Foo_0 a_4 GHC.Maybe.Maybe = GHC.Types.Bool diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr index 45c17432e1..5993cdbf82 100644 --- a/testsuite/tests/th/T10279.stderr +++ b/testsuite/tests/th/T10279.stderr @@ -1,5 +1,5 @@ -T10279.hs:10:9: error: +T10279.hs:10:9: error: [GHC-52243] • Failed to load interface for ‘A’ no unit id matching ‘rts-1.0.2’ was found (This unit ID looks like the source package ID; diff --git a/testsuite/tests/th/T10796b.stderr b/testsuite/tests/th/T10796b.stderr index 84a03ddc86..fb0dce6a8c 100644 --- a/testsuite/tests/th/T10796b.stderr +++ b/testsuite/tests/th/T10796b.stderr @@ -1,5 +1,5 @@ -T10796b.hs:8:15: error: +T10796b.hs:8:15: error: [GHC-87897] • Exception when trying to run compile-time code: Can't construct a pattern from name Data.Set.Internal.fromList CallStack (from HasCallStack): diff --git a/testsuite/tests/th/T10828a.stderr b/testsuite/tests/th/T10828a.stderr index 6f2b16465a..52ee4f4be1 100644 --- a/testsuite/tests/th/T10828a.stderr +++ b/testsuite/tests/th/T10828a.stderr @@ -1,4 +1,4 @@ -T10828a.hs:9:2: error: +T10828a.hs:9:2: error: [GHC-40746] Kind signatures are only allowed on GADTs When splicing a TH declaration: data T a :: * = MkT a a diff --git a/testsuite/tests/th/T10828b.stderr b/testsuite/tests/th/T10828b.stderr index e5f36906f7..357c86c458 100644 --- a/testsuite/tests/th/T10828b.stderr +++ b/testsuite/tests/th/T10828b.stderr @@ -1,5 +1,5 @@ -T10828b.hs:9:2: error: +T10828b.hs:9:2: error: [GHC-24104] Cannot mix GADT constructors with Haskell 98 constructors When splicing a TH declaration: data T a :: * diff --git a/testsuite/tests/th/T11452.stderr b/testsuite/tests/th/T11452.stderr index c0ed994d2d..28d0df4894 100644 --- a/testsuite/tests/th/T11452.stderr +++ b/testsuite/tests/th/T11452.stderr @@ -1,5 +1,5 @@ -T11452.hs:6:12: error: +T11452.hs:6:12: error: [GHC-94642] • Illegal polytype: (forall a. a -> a) -> () The type of a Typed Template Haskell expression must not have any quantification. • In the Template Haskell splice $$([|| \ _ -> () ||]) diff --git a/testsuite/tests/th/T12478_4.stderr b/testsuite/tests/th/T12478_4.stderr index f061f5706a..2f1b3f4e50 100644 --- a/testsuite/tests/th/T12478_4.stderr +++ b/testsuite/tests/th/T12478_4.stderr @@ -1,5 +1,5 @@ -T12478_4.hs:7:7: error: +T12478_4.hs:7:7: error: [GHC-97721] • Illegal sum arity: 1 Sums must have an arity of at least 2 When splicing a TH type: (# #) GHC.Tuple.Prim.() diff --git a/testsuite/tests/th/T15270A.stderr b/testsuite/tests/th/T15270A.stderr index ba43e4dae8..3ecd5e03ec 100644 --- a/testsuite/tests/th/T15270A.stderr +++ b/testsuite/tests/th/T15270A.stderr @@ -1,5 +1,5 @@ -T15270A.hs:8:6: error: +T15270A.hs:8:6: error: [GHC-55017] • Illegal data constructor name: ‘id’ When splicing a TH expression: GHC.Base.id • In the untyped splice: $(conE 'id) diff --git a/testsuite/tests/th/T15270B.stderr b/testsuite/tests/th/T15270B.stderr index 8db1dc4b6d..8aa4c07579 100644 --- a/testsuite/tests/th/T15270B.stderr +++ b/testsuite/tests/th/T15270B.stderr @@ -1,5 +1,5 @@ -T15270B.hs:8:6: error: +T15270B.hs:8:6: error: [GHC-55017] • Illegal variable name: ‘Just’ When splicing a TH expression: GHC.Maybe.Just • In the untyped splice: $(varE 'Just) diff --git a/testsuite/tests/th/T16895a.stderr b/testsuite/tests/th/T16895a.stderr index 5a5222eb50..17a0f55ea8 100644 --- a/testsuite/tests/th/T16895a.stderr +++ b/testsuite/tests/th/T16895a.stderr @@ -1,5 +1,5 @@ -T16895a.hs:7:15: error: +T16895a.hs:7:15: error: [GHC-99831] • Non-variable expression is not allowed in an infix expression When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2 • In the untyped splice: $(uInfixE [| 1 |] [| id id |] [| 2 |]) diff --git a/testsuite/tests/th/T16895b.stderr b/testsuite/tests/th/T16895b.stderr index 597736cad4..a63e256928 100644 --- a/testsuite/tests/th/T16895b.stderr +++ b/testsuite/tests/th/T16895b.stderr @@ -1,5 +1,5 @@ -T16895b.hs:7:15: error: +T16895b.hs:7:15: error: [GHC-99831] • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (`GHC.Base.id GHC.Base.id` 2) • In the untyped splice: diff --git a/testsuite/tests/th/T16895c.stderr b/testsuite/tests/th/T16895c.stderr index baa5e7526b..6629c60186 100644 --- a/testsuite/tests/th/T16895c.stderr +++ b/testsuite/tests/th/T16895c.stderr @@ -1,5 +1,5 @@ -T16895c.hs:7:15: error: +T16895c.hs:7:15: error: [GHC-99831] • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (1 `GHC.Base.id GHC.Base.id`) • In the untyped splice: diff --git a/testsuite/tests/th/T16895d.stderr b/testsuite/tests/th/T16895d.stderr index 2832aee9be..e080cb390a 100644 --- a/testsuite/tests/th/T16895d.stderr +++ b/testsuite/tests/th/T16895d.stderr @@ -1,5 +1,5 @@ -T16895d.hs:7:15: error: +T16895d.hs:7:15: error: [GHC-99831] • Non-variable expression is not allowed in an infix expression When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2 • In the untyped splice: diff --git a/testsuite/tests/th/T16895e.stderr b/testsuite/tests/th/T16895e.stderr index 43d7ac460e..7bed2c20db 100644 --- a/testsuite/tests/th/T16895e.stderr +++ b/testsuite/tests/th/T16895e.stderr @@ -1,5 +1,5 @@ -T16895e.hs:7:15: error: +T16895e.hs:7:15: error: [GHC-99831] • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (`GHC.Base.id GHC.Base.id`) • In the untyped splice: $(infixE Nothing [| id id |] Nothing) diff --git a/testsuite/tests/th/T16976f.stderr b/testsuite/tests/th/T16976f.stderr index ec107f2f24..f6722a0769 100644 --- a/testsuite/tests/th/T16976f.stderr +++ b/testsuite/tests/th/T16976f.stderr @@ -1,2 +1,3 @@ -T16976f.hs:5:1: error: ‘doesn'tExist’ is not in scope at a reify +T16976f.hs:5:1: error: [GHC-24922] + ‘doesn'tExist’ is not in scope at a reify diff --git a/testsuite/tests/th/T17379a.stderr b/testsuite/tests/th/T17379a.stderr index feee281ac2..ebb899e750 100644 --- a/testsuite/tests/th/T17379a.stderr +++ b/testsuite/tests/th/T17379a.stderr @@ -1,4 +1,4 @@ -T17379a.hs:8:2: error: +T17379a.hs:8:2: error: [GHC-38140] GadtC must have at least one constructor name When splicing a TH declaration: data T where :: T diff --git a/testsuite/tests/th/T17379b.stderr b/testsuite/tests/th/T17379b.stderr index 54285bde18..9a4aabc250 100644 --- a/testsuite/tests/th/T17379b.stderr +++ b/testsuite/tests/th/T17379b.stderr @@ -1,4 +1,4 @@ -T17379b.hs:8:2: error: +T17379b.hs:8:2: error: [GHC-18816] RecGadtC must have at least one constructor name When splicing a TH declaration: data T where :: {} -> T diff --git a/testsuite/tests/th/T18740d.stderr b/testsuite/tests/th/T18740d.stderr index 65c9607e88..e10e3fe673 100644 --- a/testsuite/tests/th/T18740d.stderr +++ b/testsuite/tests/th/T18740d.stderr @@ -1,5 +1,5 @@ -T18740d.hs:17:7: error: +T18740d.hs:17:7: error: [GHC-55017] • Illegal variable name: ‘Bool’ When splicing a TH expression: GHC.Types.Bool • In the untyped splice: $(return (VarE ''Bool)) diff --git a/testsuite/tests/th/T19470.stderr b/testsuite/tests/th/T19470.stderr index 86788d1b73..04d92ba65b 100644 --- a/testsuite/tests/th/T19470.stderr +++ b/testsuite/tests/th/T19470.stderr @@ -1,5 +1,5 @@ -<interactive>:2:10: error: +<interactive>:2:10: error: [GHC-87897] • Exception when trying to run compile-time code: Prelude.undefined CallStack (from HasCallStack): diff --git a/testsuite/tests/th/T19709d.stderr b/testsuite/tests/th/T19709d.stderr index ea19ba8f4c..8599b05fbc 100644 --- a/testsuite/tests/th/T19709d.stderr +++ b/testsuite/tests/th/T19709d.stderr @@ -9,7 +9,7 @@ T19709d.hs:6:2: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] ('h':p:_) where p is not one of {'e'} ... -T19709d.hs:1:1: error: +T19709d.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: T19709d.hs:6:2-46: Non-exhaustive patterns in case diff --git a/testsuite/tests/th/T2597b.stderr b/testsuite/tests/th/T2597b.stderr index aba3925113..9be4b602b9 100644 --- a/testsuite/tests/th/T2597b.stderr +++ b/testsuite/tests/th/T2597b.stderr @@ -1,5 +1,5 @@ -T2597b.hs:8:9: error: +T2597b.hs:8:9: error: [GHC-34949] • Empty stmt list in do-block When splicing a TH expression: do • In the untyped splice: $mkBug2 diff --git a/testsuite/tests/th/T2674.stderr b/testsuite/tests/th/T2674.stderr index 9c7f0baff7..10d0feb9c6 100644 --- a/testsuite/tests/th/T2674.stderr +++ b/testsuite/tests/th/T2674.stderr @@ -1,4 +1,4 @@ -T2674.hs:9:2: error: +T2674.hs:9:2: error: [GHC-52078] Function binding for ‘foo’ has no equations When splicing a TH declaration: diff --git a/testsuite/tests/th/T3395.stderr b/testsuite/tests/th/T3395.stderr index a9bcdbedba..d1a56d707d 100644 --- a/testsuite/tests/th/T3395.stderr +++ b/testsuite/tests/th/T3395.stderr @@ -1,5 +1,5 @@ -T3395.hs:6:8: error: +T3395.hs:6:8: error: [GHC-47373] • Illegal last statement of a list comprehension: r1 <- undefined (It should be an expression.) diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index 4dfd36f8c4..adf00b5195 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -29,7 +29,7 @@ T5358.hs:10:21: error: [GHC-83865] x :: t (bound at T5358.hs:10:9) prop_x1 :: t -> Bool (bound at T5358.hs:10:1) -T5358.hs:14:12: error: +T5358.hs:14:12: error: [GHC-87897] • Exception when trying to run compile-time code: runTest called error: forall {t_0 :: *} . t_0 -> GHC.Types.Bool CallStack (from HasCallStack): diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr index 7d815f2b30..aef0061224 100644 --- a/testsuite/tests/th/T5976.stderr +++ b/testsuite/tests/th/T5976.stderr @@ -1,5 +1,5 @@ -T5976.hs:1:1: error: +T5976.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: bar CallStack (from HasCallStack): diff --git a/testsuite/tests/th/T7276.stderr b/testsuite/tests/th/T7276.stderr index 4c73db695a..a17f7b3f35 100644 --- a/testsuite/tests/th/T7276.stderr +++ b/testsuite/tests/th/T7276.stderr @@ -1,5 +1,5 @@ -T7276.hs:6:5: error: +T7276.hs:6:5: error: [GHC-87897] • Exception when trying to run compile-time code: T7276.hs:6:8: error: [GHC-83865] • Couldn't match type ‘[Language.Haskell.TH.Syntax.Dec]’ diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout index 68f6791443..a199732f6f 100644 --- a/testsuite/tests/th/T7276a.stdout +++ b/testsuite/tests/th/T7276a.stdout @@ -6,7 +6,7 @@ • In the expression: [d| a = () |] :: Q Exp In an equation for ‘x’: x = [d| a = () |] :: Q Exp -<interactive>:1:1: error: +<interactive>:1:1: error: [GHC-87897] • Exception when trying to run compile-time code: <interactive>:3:9: error: [GHC-83865] • Couldn't match type ‘[Dec]’ with ‘Exp’ diff --git a/testsuite/tests/th/T7477.stderr b/testsuite/tests/th/T7477.stderr index 7aee71ea74..0fd6f4fc3b 100644 --- a/testsuite/tests/th/T7477.stderr +++ b/testsuite/tests/th/T7477.stderr @@ -1,3 +1,3 @@ -T7477.hs:10:2: warning: +T7477.hs:10:2: warning: [GHC-39584] type instance T7477.F GHC.Types.Int = GHC.Types.Bool diff --git a/testsuite/tests/th/T7484.stderr b/testsuite/tests/th/T7484.stderr index 5964a2f73c..0d67b6c25b 100644 --- a/testsuite/tests/th/T7484.stderr +++ b/testsuite/tests/th/T7484.stderr @@ -1,4 +1,4 @@ -T7484.hs:7:2: error: +T7484.hs:7:2: error: [GHC-55017] Illegal variable name: ‘a ’ When splicing a TH declaration: a = 5 diff --git a/testsuite/tests/th/T7667a.stderr b/testsuite/tests/th/T7667a.stderr index b9807f0e0c..c53ab42c75 100644 --- a/testsuite/tests/th/T7667a.stderr +++ b/testsuite/tests/th/T7667a.stderr @@ -1,5 +1,5 @@ -T7667a.hs:8:10: error: +T7667a.hs:8:10: error: [GHC-55017] • Illegal variable name: ‘False’ When splicing a TH expression: False • In the untyped splice: $(return $ VarE (mkName "False")) diff --git a/testsuite/tests/th/T8759.stderr b/testsuite/tests/th/T8759.stderr index d3cde8b0a8..2e551478ae 100644 --- a/testsuite/tests/th/T8759.stderr +++ b/testsuite/tests/th/T8759.stderr @@ -1,3 +1,3 @@ -T8759.hs:9:2: warning: +T8759.hs:9:2: warning: [GHC-39584] PatSynI T8759.P (ForallT [] [] (ForallT [] [] (TupleT 0))) diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr index 9933ef3465..58386006b8 100644 --- a/testsuite/tests/th/T8987.stderr +++ b/testsuite/tests/th/T8987.stderr @@ -1,5 +1,5 @@ -T8987.hs:1:1: error: +T8987.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: Prelude.undefined CallStack (from HasCallStack): diff --git a/testsuite/tests/th/TH_PromotedList.stderr b/testsuite/tests/th/TH_PromotedList.stderr index d3eba9ac0e..093924b3ae 100644 --- a/testsuite/tests/th/TH_PromotedList.stderr +++ b/testsuite/tests/th/TH_PromotedList.stderr @@ -1,3 +1,3 @@ -TH_PromotedList.hs:11:2: warning: +TH_PromotedList.hs:11:2: warning: [GHC-39584] '(:) GHC.Types.Int ('(:) GHC.Types.Bool '[]) diff --git a/testsuite/tests/th/TH_PromotedTuple.stderr b/testsuite/tests/th/TH_PromotedTuple.stderr index 29b60f08fd..4579f76c2b 100644 --- a/testsuite/tests/th/TH_PromotedTuple.stderr +++ b/testsuite/tests/th/TH_PromotedTuple.stderr @@ -5,5 +5,5 @@ TH_PromotedTuple.hs:(14,31)-(16,44): Splicing type ======> '(Int, 'False) -TH_PromotedTuple.hs:14:31: warning: +TH_PromotedTuple.hs:14:31: warning: [GHC-39584] AppT (AppT (PromotedTupleT 2) (ConT GHC.Types.Int)) (PromotedT GHC.Types.False) diff --git a/testsuite/tests/th/TH_RichKinds.stderr b/testsuite/tests/th/TH_RichKinds.stderr index 920e424e52..cb8cbb9f34 100644 --- a/testsuite/tests/th/TH_RichKinds.stderr +++ b/testsuite/tests/th/TH_RichKinds.stderr @@ -1,5 +1,5 @@ -TH_RichKinds.hs:12:2: warning: +TH_RichKinds.hs:12:2: warning: [GHC-39584] forall a_0 . (a_0 :: GHC.Types.Bool) forall a_1 . (a_1 :: Constraint) forall a_2 . (a_2 :: [*]) diff --git a/testsuite/tests/th/TH_RichKinds2.stderr b/testsuite/tests/th/TH_RichKinds2.stderr index ae842d43a6..89b7279114 100644 --- a/testsuite/tests/th/TH_RichKinds2.stderr +++ b/testsuite/tests/th/TH_RichKinds2.stderr @@ -1,5 +1,5 @@ -TH_RichKinds2.hs:25:2: warning: +TH_RichKinds2.hs:25:2: warning: [GHC-39584] data SMaybe_0 :: (k_0 -> *) -> GHC.Maybe.Maybe k_0 -> * where SNothing_2 :: SMaybe_0 s_3 'GHC.Maybe.Nothing SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Maybe.Just a_6) diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr index bbeabab267..b0827881d5 100644 --- a/testsuite/tests/th/TH_TyInstWhere2.stderr +++ b/testsuite/tests/th/TH_TyInstWhere2.stderr @@ -1,10 +1,10 @@ -TH_TyInstWhere2.hs:8:2: warning: +TH_TyInstWhere2.hs:8:2: warning: [GHC-39584] type family F_0 (a_1 :: k_2) (b_3 :: k_2) :: GHC.Types.Bool where F_0 a_4 a_4 = 'GHC.Types.True F_0 a_5 b_6 = 'GHC.Types.False -TH_TyInstWhere2.hs:14:2: warning: +TH_TyInstWhere2.hs:14:2: warning: [GHC-39584] type family F1_0 (a_1 :: k_2) :: * where F1_0 @(*) GHC.Types.Int = GHC.Types.Bool F1_0 @GHC.Types.Bool 'GHC.Types.False = GHC.Types.Char diff --git a/testsuite/tests/th/TH_exn1.stderr b/testsuite/tests/th/TH_exn1.stderr index 540ced9278..985b33bb87 100644 --- a/testsuite/tests/th/TH_exn1.stderr +++ b/testsuite/tests/th/TH_exn1.stderr @@ -1,5 +1,5 @@ -TH_exn1.hs:1:1: error: +TH_exn1.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: TH_exn1.hs:(9,2)-(11,2): Non-exhaustive patterns in case diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr index 9d9205056c..a7fefabc78 100644 --- a/testsuite/tests/th/TH_exn2.stderr +++ b/testsuite/tests/th/TH_exn2.stderr @@ -1,10 +1,10 @@ -TH_exn2.hs:1:1: error: +TH_exn2.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: Prelude.tail: empty list CallStack (from HasCallStack): - error, called at libraries/base/GHC/List.hs:1590:3 in base:GHC.List - errorEmptyList, called at libraries/base/GHC/List.hs:114:28 in base:GHC.List + error, called at libraries/base/GHC/List.hs:1650:3 in base:GHC.List + errorEmptyList, called at libraries/base/GHC/List.hs:130:28 in base:GHC.List tail, called at TH_exn2.hs:10:17 in main:TH Code: (do ds <- [d| |] return (tail ds)) diff --git a/testsuite/tests/th/TH_fail.stderr b/testsuite/tests/th/TH_fail.stderr index 6df144dae4..f3692edc1e 100644 --- a/testsuite/tests/th/TH_fail.stderr +++ b/testsuite/tests/th/TH_fail.stderr @@ -1,2 +1,2 @@ -TH_fail.hs:7:2: error: Code not written yet... +TH_fail.hs:7:2: error: [GHC-39584] Code not written yet... diff --git a/testsuite/tests/th/TH_finalizer.stderr b/testsuite/tests/th/TH_finalizer.stderr index e89d434adb..dedb26ff3f 100644 --- a/testsuite/tests/th/TH_finalizer.stderr +++ b/testsuite/tests/th/TH_finalizer.stderr @@ -1,2 +1,2 @@ -TH_finalizer.hs:1:1: warning: Just True +TH_finalizer.hs:1:1: warning: [GHC-39584] Just True diff --git a/testsuite/tests/th/TH_implicitParamsErr1.stderr b/testsuite/tests/th/TH_implicitParamsErr1.stderr index 56acdfdabb..9b76c6514c 100644 --- a/testsuite/tests/th/TH_implicitParamsErr1.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr1.stderr @@ -1,4 +1,4 @@ -TH_implicitParamsErr1.hs:5:2: error: +TH_implicitParamsErr1.hs:5:2: error: [GHC-51603] Implicit parameter binding only allowed in let or where When splicing a TH declaration: ?x = 1 diff --git a/testsuite/tests/th/TH_implicitParamsErr2.stderr b/testsuite/tests/th/TH_implicitParamsErr2.stderr index faa2a9e90b..cfded82312 100644 --- a/testsuite/tests/th/TH_implicitParamsErr2.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr2.stderr @@ -1,5 +1,5 @@ -TH_implicitParamsErr2.hs:5:9: error: +TH_implicitParamsErr2.hs:5:9: error: [GHC-42974] • Implicit parameters mixed with other bindings When splicing a TH expression: let {?x = 1; y = 2} in y diff --git a/testsuite/tests/th/TH_implicitParamsErr3.stderr b/testsuite/tests/th/TH_implicitParamsErr3.stderr index a83ead7a0a..9efd60733c 100644 --- a/testsuite/tests/th/TH_implicitParamsErr3.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr3.stderr @@ -1,5 +1,5 @@ -TH_implicitParamsErr3.hs:5:15: error: +TH_implicitParamsErr3.hs:5:15: error: [GHC-55017] • Illegal variable name: ‘invalid name’ When splicing a TH expression: let ?invalid name = "hi" diff --git a/testsuite/tests/th/TH_invalid_add_top_decl.stderr b/testsuite/tests/th/TH_invalid_add_top_decl.stderr index 0e8f6b66c2..84e56a275b 100644 --- a/testsuite/tests/th/TH_invalid_add_top_decl.stderr +++ b/testsuite/tests/th/TH_invalid_add_top_decl.stderr @@ -1,5 +1,5 @@ -TH_invalid_add_top_decl.hs:5:2: error: +TH_invalid_add_top_decl.hs:5:2: error: [GHC-34949] Error in a declaration passed to addTopDecls: Empty stmt list in do-block When splicing a TH declaration: emptyDo = do diff --git a/testsuite/tests/th/TH_runIO.stderr b/testsuite/tests/th/TH_runIO.stderr index 50af621620..aae6b27102 100644 --- a/testsuite/tests/th/TH_runIO.stderr +++ b/testsuite/tests/th/TH_runIO.stderr @@ -1,5 +1,5 @@ -TH_runIO.hs:12:7: error: +TH_runIO.hs:12:7: error: [GHC-87897] • Exception when trying to run compile-time code: user error (hi) Code: (runIO (fail "hi")) |