Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 0b0b8999 by Apoorv Ingle at 2025-07-14T08:58:20-05:00 - kill ExpectedFunTyOrigin and incorporate it into CtOrigin - fix error message suggestions for record fields - - - - - 9 changed files: - compiler/GHC/Tc/Errors.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/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -24,6 +24,10 @@ import GHC.Driver.Config.Diagnostic import GHC.Rename.Unbound +import Language.Haskell.Syntax (DotFieldOcc (..)) +import Language.Haskell.Syntax.Basic (FieldLabelString (..)) +import GHC.Hs.Expr (SrcCodeOrigin (..), HsExpr (..)) + import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types @@ -2349,7 +2353,7 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) isNothing (lookupLocalRdrOcc lcl_env occ_name) record_field = case orig of - GetFieldOrigin name -> Just (mkVarOccFS name) + ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ name))) -> Just (mkVarOccFS (field_label $ unLoc $ dfoLabel name)) _ -> Nothing {- Note [Report candidate instances] ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -857,7 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) - = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) + = do { let herald = ExpectedFunTyArg pos (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int @@ -876,7 +876,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i = do { arg_nu <- newOpenFlexiFRRTyVarTy $ - FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i + FRRExpectedFunTy (ExpectedFunTyArg i (HsExprTcThing tc_fun) arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -976,7 +976,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 orig op + herald = ExpectedFunTySyntaxOp 1 orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1005,7 +1005,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 orig op + herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -655,7 +655,7 @@ tcInferOverLit lit@(OverLit { ol_val = val ; let thing = NameThing from_name mb_thing = Just thing - herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) + herald = ExpectedFunTyArg 1 thing (HsLit noExtField hs_lit) ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -118,7 +118,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 ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) @@ -138,7 +138,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty ; return (wrap_fun, r) } where mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn - herald = ExpectedFunTyMatches (NameThing fun_name) matches + funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts }) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -698,7 +698,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Note [View patterns and polymorphism] -- Expression must be a function - ; let herald = ExpectedFunTyViewPat $ unLoc expr + ; let herald = ExpectedFunTyViewPat 1 $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty -- See Note [View patterns and polymorphism] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -17,7 +17,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin ) +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) import GHC.Tc.Zonk.Monad ( ZonkM ) @@ -120,7 +120,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int + | FunTysCtxt !CtOrigin !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/Origin.hs ===================================== @@ -21,6 +21,7 @@ module GHC.Tc.Types.Origin ( CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, srcCodeOriginCtOrigin, isVisibleOrigin, toInvisibleOrigin, + updatePositionCtOrigin, pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, isWantedSuperclassOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), @@ -45,7 +46,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, + pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -653,8 +654,67 @@ data CtOrigin Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice + | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin + -- | 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 + Int + -- ^ Argument number + !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 + +updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin +updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e +updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e +updatePositionCtOrigin i (ExpectedFunTyArg _ t e) = ExpectedFunTyArg i t e +updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e +updatePositionCtOrigin _ c = c + + data NonLinearPatternReason = LazyPatternReason | GeneralisedPatternReason @@ -727,7 +787,8 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f) +exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e) + -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip @@ -739,7 +800,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (HsProjection _ p) = GetFieldOrigin ((field_label . unLoc . dfoLabel . NE.head . NE.reverse) p) +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" @@ -802,7 +863,7 @@ pprCtOrigin (ExpansionOrigin o) where what :: SDoc what = case o of OrigStmt{} -> text "a do statement" - OrigExpr e -> text "an expression" <+> ppr e + OrigExpr e -> pprCtO (exprCtOrigin e) OrigPat p -> text "a pattern" <+> ppr p pprCtOrigin (GivenSCOrigin sk d blk) @@ -917,9 +978,38 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) +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 i fun arg) = + sep [ text "The" <+> speakNth i <+> text "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 simple_origin = ctoHerald <+> pprCtO 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" + + -- | Short one-liners pprCtO :: HasDebugCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] @@ -945,7 +1035,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoStmtOrigin = text "a do statement" +pprCtO DoStmtOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" @@ -990,7 +1080,13 @@ pprCtO (ImpedanceMatching {}) = text "combining required constraints" pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)] pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement" -pprCtO (ExpansionOrigin (OrigExpr{})) = text "an expression" +pprCtO (ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ f)))) = hsep [text "selecting the field", quotes (ppr f)] +pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e +pprCtO (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" +pprCtO (ExpectedFunTyViewPat{}) = text "a view pattern" +pprCtO (ExpectedFunTyArg{}) = text "a funtion head" +pprCtO (ExpectedFunTyMatches{}) = text "a match statement" +pprCtO (ExpectedFunTyLam{}) = text "a lambda expression" pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc @@ -1204,7 +1300,7 @@ data FixedRuntimeRepContext -- -- See 'ExpectedFunTyOrigin' for more details. | FRRExpectedFunTy - !ExpectedFunTyOrigin + !CtOrigin -- !ExpectedFunTyOrigin !Int -- ^ argument position (1-indexed) @@ -1285,8 +1381,8 @@ pprFixedRuntimeRepContext FRRBindStmtGuard = sep [ text "The body of the bind statement" ] pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext -pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos) - = pprExpectedFunTyOrigin funTyOrig arg_pos +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) + = pprCtOrigin funTyOrig instance Outputable FixedRuntimeRepContext where ppr = pprFixedRuntimeRepContext @@ -1439,102 +1535,56 @@ instance Outputable FRRArrowContext where -- Uses 'pprExpectedFunTyOrigin'. -- See 'FixedRuntimeRepContext' for the situations in which -- representation-polymorphism checks are performed. -data ExpectedFunTyOrigin - - -- | 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 - - -- | 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 - -pprExpectedFunTyOrigin :: ExpectedFunTyOrigin - -> Int -- ^ argument position (starting at 1) - -> SDoc -pprExpectedFunTyOrigin 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) ] - 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 - 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 :: ExpectedFunTyOrigin -> SDoc +-- pprExpectedFunTyOrigin :: -- ExpectedFunTyOrigin +-- -- -> Int -- ^ argument position (starting at 1) +-- -> SDoc +-- pprExpectedFunTyOrigin funTy_origin = +-- case funTy_origin of +-- ExpectedFunTySyntaxOp i orig op -> +-- vcat [ sep [ the_arg_of +-- , text "the rebindable syntax operator" +-- , quotes (ppr op) ] +-- , nest 2 (ppr orig) ] +-- ExpectedFunTyViewPat i 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 i 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 +-- where +-- 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" + +pprExpectedFunTyHerald :: CtOrigin -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" -pprExpectedFunTyHerald (ExpectedFunTyArg fun _) +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" <+> quotes (pprSetDepth (PartWay 1) (ppr expr)) -- The pprSetDepth makes the lambda abstraction print briefly , text "has" ] +pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -135,7 +135,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: ExpectedFunTyOrigin + :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -174,7 +174,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 { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty + do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty ; return (idHsWrapper, Scaled w arg_ty, res_ty) } go ty@(TyVarTy tv) @@ -241,7 +241,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 :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -776,7 +776,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. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + CtOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -852,7 +852,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) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty + ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty ; (wrap_res, result) <- check (n_req - 1) (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys) res_ty @@ -905,19 +905,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 :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) +new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy - ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: CtOrigin -> 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 herald arg_pos) + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: ExpectedFunTyOrigin +mkFunTysMsg :: CtOrigin -> (VisArity, TcType) -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -- See Note [Reporting application arity errors] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b0b8999c64e5ff3fe1889ad345a869c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b0b8999c64e5ff3fe1889ad345a869c... You're receiving this email because of your account on gitlab.haskell.org.