Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 93003cd2 by Apoorv Ingle at 2026-03-08T21:48:20-05:00 remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign from ErrMsgCtxt.FunTysCtxt - - - - - 13 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -83,7 +83,6 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Language.Haskell.Syntax (HsExpr (RecordUpd, HsGetField, HsProjection)) import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) @@ -2778,10 +2777,6 @@ isHasFieldOrigin = \case RecordUpdOrigin {} -> True RecordFieldProjectionOrigin {} -> True GetFieldOrigin {} -> True - ExpansionOrigin (ExprCtxt e) - | HsGetField{} <- e -> True - | RecordUpd{} <- e -> True - | HsProjection{} <- e -> True _ -> False ----------------------- ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7798,6 +7798,7 @@ pprErrCtxtMsg = \case | otherwise -> empty + -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -907,10 +907,10 @@ tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigm ; return (mkScaled mult_ty arg_nu) } - mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> CtOrigin + mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt mk_herald tc_fun arg = case fun_orig of - ExpansionOrigin (StmtErrCtxt{}) -> ExpectedTySyntax DoStmtOrigin arg + DoStmtOrigin -> ExpectedTySyntax DoStmtOrigin arg _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg -- Is the argument supposed to instantiate a forall? ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1068,7 +1068,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = ExpectedFunTySyntaxOp 1 orig op + herald = ExpectedFunTySyntaxOp orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1097,7 +1097,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op + herald = ExpectedFunTySyntaxOp orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) @@ -1849,4 +1849,3 @@ checkMissingFields con_like rbinds arg_tys field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -465,7 +465,7 @@ tcInferAppHead_maybe fun = case fun of -- visible type applications in the argument. -- c.f. T19167 (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$> - tcExprSigma False (ExpansionOrigin o) e + tcExprSigma False (errCtxtCtOrigin o) e ) _ -> return Nothing ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -114,7 +114,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments arity <- checkArgCounts matches - ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches + ; let herald = ExpectedFunTyMatches (NameThing fun_name) matches ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -701,7 +701,7 @@ tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside = -- 'view_expr' must be a function; expose its argument/result types -- using 'matchActualFunTy'. - ; let herald = ExpectedFunTyViewPat 1 $ unLoc view_expr + ; let herald = ExpectedFunTyViewPat $ unLoc view_expr ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr) (1, view_expr_rho) view_expr_rho ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1288,7 +1288,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (ExpansionOrigin (ExprCtxt (HsGetField {}))) = True + isGetFieldOrigin GetFieldOrigin{} = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, ExpectedFunTyCtxt ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon, ExpType ) import GHC.Types.Basic ( TyConFlavour ) @@ -283,7 +283,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !CtOrigin !Type !Int !Int + | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int -- | In the declaration of a type constructor. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -211,9 +211,6 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) -- See Note [ErrCtxtStack Manipulation] setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin ec lclCtxt - -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt - -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec - -- = lclCtxt { tcl_err_ctxt = ec : ecs } -- never stack 2 statement error contexts on top of each other | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt , MkErrCtxt _ DoStmtErrCtxt{} <- ec ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -9,9 +9,8 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeOriginCtOrigin, + srcCodeOriginCtOrigin, errCtxtCtOrigin, invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin, - updatePositionCtOrigin, pprCtOrigin, pprCtOriginBriefly, isGivenOrigin, defaultReprEqOrigins, isWantedSuperclassOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), @@ -37,7 +36,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - pprExpectedFunTyHerald, + ExpectedFunTyCtxt(..), pprExpectedFunTyCtxt, pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -512,72 +511,6 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice - | ExpansionOrigin ErrCtxtMsg -- This is due to an expansion of the original thing given by the ErrCtxtMsg - - | ExpectedTySyntax !CtOrigin (HsExpr GhcRn) - - -- | A rebindable syntax operator is expected to have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - | forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTySyntaxOp Int - !CtOrigin !(HsExpr (GhcPass p)) - -- ^ rebindable syntax operator - - -- | A view pattern must have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder - | ExpectedFunTyViewPat Int - !(HsExpr GhcRn) - -- ^ function used in the view pattern - - -- | Need to be able to extract an argument type from a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyApp - | forall (p :: Pass) - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg - !TypedThing - -- ^ function - !(HsExpr (GhcPass p)) - -- ^ argument - - -- | Ensure that a function defined by equations indeed has a function type - -- with the appropriate number of arguments. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern - | ExpectedFunTyMatches Int - !TypedThing - -- ^ name of the function - !(MatchGroup GhcRn (LHsExpr GhcRn)) - -- ^ equations - - -- | Ensure that a lambda abstraction has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyLambda, RepPolyMatch - | ExpectedFunTyLam HsLamVariant - !(HsExpr GhcRn) - -- ^ the entire lambda-case expression - - -- | A partial application of the constructor of a representation-polymorphic - -- unlifted newtype in which the argument type does not have a fixed - -- runtime representation. - -- - -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. - | FRRRepPolyUnliftedNewtype !DataCon - - -updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin -updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e -updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e -updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e -updatePositionCtOrigin _ c = c - data NonLinearPatternReason = LazyPatternReason @@ -680,18 +613,18 @@ exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" -exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" -exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] -exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] -exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e) +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" +exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" +exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] +exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] +exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin (ExplicitList {}) = ListOrigin +exprCtOrigin (HsIf {}) = IfThenElseOrigin +exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p) +exprCtOrigin (RecordUpd _ _ flds) = RecordUpdOrigin flds +exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f)) exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) @@ -736,31 +669,6 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk -pprCtOrigin (ExpansionOrigin o) - = ctoHerald <+> what - where - what :: SDoc - what = case o of - StmtErrCtxt{} -> - text "a do statement" - DoStmtErrCtxt{} -> - text "a do statement" - StmtErrCtxtPat _ _ p -> - text "a do statement" $$ - text "with the failable pattern" <+> quotes (ppr p) - ExprCtxt (HsGetField _ _ (L _ f)) -> - hsep [text "selecting the field", quotes (ppr f)] - ExprCtxt (HsOverLabel _ l) -> - hsep [text "the overloaded label" , quotes (char '#' <> ppr l)] - ExprCtxt (RecordUpd{}) -> text "a record update" - ExprCtxt (ExplicitList{}) -> text "an overloaded list" - ExprCtxt (HsIf{}) -> text "an if-then-else expression" - ExprCtxt (HsProjection _ p) -> text "the record selector" <+> - quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) - ExprCtxt e -> text "the expression" <+> (ppr e) - RecordUpdCtxt{} -> text "a record update" - _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin" - pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -867,46 +775,9 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) -pprCtOrigin (ExpectedTySyntax orig arg) - = vcat [ text "The expression" <+> quotes (ppr arg) - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTySyntaxOp i orig op) = - vcat [ sep [ the_arg_of i - , text "the rebindable syntax operator" - , quotes (ppr op) ] - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTyViewPat i expr) = - vcat [ the_arg_of i <+> text "the view pattern" - , nest 2 (ppr expr) ] -pprCtOrigin (ExpectedFunTyArg fun arg) = - sep [ text "The argument" - , quotes (ppr arg) - , text "of" - , quotes (ppr fun) ] -pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts })) - | null alts - = the_arg_of i <+> quotes (ppr fun) - | otherwise - = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts - <+> text "for" <+> quotes (ppr fun) -pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant -pprCtOrigin (FRRRepPolyUnliftedNewtype dc) = - vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." - , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] - pprCtOrigin simple_origin = ctoHerald <+> pprCtOriginBriefly simple_origin -the_arg_of :: Int -> SDoc -the_arg_of i = text "The" <+> speakNth i <+> text "argument of" - -binder_of :: SDoc -> SDoc -binder_of what = text "The binder of the" <+> what <+> text "expression" - - - -- | Print CtOrigin briefly, with a one-liner pprCtOriginBriefly :: CtOrigin -> SDoc pprCtOriginBriefly = ppr_br -- ppr_br is a local function with a short name! @@ -979,22 +850,6 @@ ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" ppr_br (ImpedanceMatching {}) = text "combining required constraints" ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] -ppr_br (ExpansionOrigin (ExprCtxt (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] -ppr_br (ExpansionOrigin (ExprCtxt (RecordUpd{}))) = text "a record update" -ppr_br (ExpansionOrigin (ExprCtxt (ExplicitList{}))) = text "an overloaded list" -ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression" -ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e -ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement" -ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement" -ppr_br (ExpansionOrigin{}) = text "shouldn't happen ExpansionOrigin ppr_br" -ppr_br (ExpectedTySyntax o _) = ppr_br o -ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" -ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" -ppr_br (ExpectedFunTyArg{}) = text "a funtion head" -ppr_br (ExpectedFunTyMatches{}) = text "a match statement" -ppr_br (ExpectedFunTyLam{}) = text "a lambda expression" -ppr_br (FRRRepPolyUnliftedNewtype{}) = text "a unlifted newtype" - pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") @@ -1225,9 +1080,9 @@ data FixedRuntimeRepContext -- | A representation-polymorphism check arising from a call -- to 'matchExpectedFunTys' or 'matchActualFunTy'. -- - -- See 'ExpectedFunTyOrigin' for more details. + -- See 'ExpectedFunTyCtxt' for more details. | FRRExpectedFunTy - !CtOrigin + !ExpectedFunTyCtxt !Int -- ^ argument position (1-indexed) @@ -1314,7 +1169,7 @@ pprFixedRuntimeRepContext FRRBindStmtGuard pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) - = pprCtOrigin funTyOrig + = pprExpectedFunTyHerald funTyOrig pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun) = hsep [ text "The", what, text "type of the" , ppr (Argument pos) @@ -1540,15 +1395,136 @@ instance Outputable FRRArrowContext where ppr = pprFRRArrowContext -pprExpectedFunTyHerald :: CtOrigin -> SDoc +{- ********************************************************************* +* * + FixedRuntimeRep: ExpectedFunTy origin +* * +********************************************************************* -} + +-- | In what context are we calling 'matchExpectedFunTys' +-- or 'matchActualFunTy'? +-- +-- Used for two things: +-- +-- 1. Reporting error messages which explain that a function has been +-- given an unexpected number of arguments. +-- Uses 'pprExpectedFunTyHerald'. +-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. +-- +-- 2. Reporting representation-polymorphism errors when a function argument +-- doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- Uses 'pprExpectedFunTyCtxt'. +-- See 'FixedRuntimeRepContext' for the situations in which +-- representation-polymorphism checks are performed. +data ExpectedFunTyCtxt + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + = forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | + | ExpectedTySyntax !CtOrigin !(HsExpr GhcRn) + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + + -- | A partial application of the constructor of a representation-polymorphic + -- unlifted newtype in which the argument type does not have a fixed + -- runtime representation. + -- + -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRRepPolyUnliftedNewtype !DataCon + +pprExpectedFunTyCtxt :: ExpectedFunTyCtxt + -> Int -- ^ argument position (starting at 1) + -> SDoc +pprExpectedFunTyCtxt funTy_origin i = + case funTy_origin of + ExpectedFunTySyntaxOp orig op -> + vcat [ sep [ the_arg_of + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] + ExpectedTySyntax orig arg -> + vcat [ text "the expression" <+> quotes (ppr arg) + , nest 2 (ppr orig) ] + ExpectedFunTyViewPat expr -> + vcat [ the_arg_of <+> text "the view pattern" + , nest 2 (ppr expr) ] + ExpectedFunTyArg fun arg -> + sep [ text "The argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] + ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) + | null alts + -> the_arg_of <+> quotes (ppr fun) + | otherwise + -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) + ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant + FRRRepPolyUnliftedNewtype dc -> + vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." + , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] + where + the_arg_of :: SDoc + the_arg_of = text "The" <+> speakNth i <+> text "argument of" + + binder_of :: SDoc -> SDoc + binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: ExpectedFunTyCtxt -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" +pprExpectedFunTyHerald (ExpectedTySyntax orig _) + = pprCtOriginBriefly orig pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" pprExpectedFunTyHerald (ExpectedFunTyArg fun _) = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to" ] -pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts })) +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" @@ -1557,7 +1533,6 @@ pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) , text "has" ] pprExpectedFunTyHerald (FRRRepPolyUnliftedNewtype dc) = text "The unlifted newtype" <+> quotes (ppr dc) <+> text "expects" -pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -5,6 +5,7 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data CtOrigin +data ExpectedFunTyOrigin data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -139,7 +139,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: CtOrigin + :: ExpectedFunTyCtxt -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -178,7 +178,7 @@ matchActualFunTy herald mb_thing err_info fun_ty go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty + do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald 1) arg_ty ; let fun_co = mkFunCo Nominal af (mkReflCo Nominal w) arg_co @@ -249,7 +249,7 @@ Ugh! -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: ExpectedFunTyCtxt -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -793,7 +793,7 @@ Example: -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - CtOrigin -- See Note [Herald for matchExpectedFunTys] + ExpectedFunTyCtxt -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -875,7 +875,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc - ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty + ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr ; (res_wrap, result) <- check (n_req - 1) (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys) @@ -947,19 +947,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) +new_infer_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled ExpRhoTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy - ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled TcType) new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy - ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: CtOrigin +mkFunTysMsg :: ExpectedFunTyCtxt -> (VisArity, TcType) -> ErrCtxtMsg -- See Note [Reporting application arity errors] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93003cd213439d70af0ca6728e7660bf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93003cd213439d70af0ca6728e7660bf... You're receiving this email because of your account on gitlab.haskell.org.