Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
-
eb0e4601
by Apoorv Ingle at 2025-07-14T09:35:45-05:00
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:
... | ... | @@ -24,6 +24,10 @@ import GHC.Driver.Config.Diagnostic |
24 | 24 | |
25 | 25 | import GHC.Rename.Unbound
|
26 | 26 | |
27 | +import Language.Haskell.Syntax (DotFieldOcc (..))
|
|
28 | +import Language.Haskell.Syntax.Basic (FieldLabelString (..))
|
|
29 | +import GHC.Hs.Expr (SrcCodeOrigin (..), HsExpr (..))
|
|
30 | + |
|
27 | 31 | import GHC.Tc.Types
|
28 | 32 | import GHC.Tc.Utils.Monad
|
29 | 33 | import GHC.Tc.Errors.Types
|
... | ... | @@ -2349,7 +2353,7 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) |
2349 | 2353 | isNothing (lookupLocalRdrOcc lcl_env occ_name)
|
2350 | 2354 | |
2351 | 2355 | record_field = case orig of
|
2352 | - GetFieldOrigin name -> Just (mkVarOccFS name)
|
|
2356 | + ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ name))) -> Just (mkVarOccFS (field_label $ unLoc $ dfoLabel name))
|
|
2353 | 2357 | _ -> Nothing
|
2354 | 2358 | |
2355 | 2359 | {- Note [Report candidate instances]
|
... | ... | @@ -857,7 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args |
857 | 857 | -- Rule IARG from Fig 4 of the QL paper:
|
858 | 858 | go1 pos acc fun_ty
|
859 | 859 | (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
|
860 | - = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
|
|
860 | + = do { let herald = ExpectedFunTyArg pos (HsExprTcThing tc_fun) (unLoc arg)
|
|
861 | 861 | ; (wrap, arg_ty, res_ty) <-
|
862 | 862 | -- NB: matchActualFunTy does the rep-poly check.
|
863 | 863 | -- 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 |
876 | 876 | -- Make a fresh nus for each argument in rule IVAR
|
877 | 877 | new_arg_ty (L _ arg) i
|
878 | 878 | = do { arg_nu <- newOpenFlexiFRRTyVarTy $
|
879 | - FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i
|
|
879 | + FRRExpectedFunTy (ExpectedFunTyArg i (HsExprTcThing tc_fun) arg) i
|
|
880 | 880 | -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc],
|
881 | 881 | -- thereby ensuring that the arguments have concrete runtime representations
|
882 | 882 |
... | ... | @@ -976,7 +976,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside |
976 | 976 | -- fixed RuntimeRep, as needed to call mkWpFun.
|
977 | 977 | ; return (result, match_wrapper <.> fun_wrap) }
|
978 | 978 | where
|
979 | - herald = ExpectedFunTySyntaxOp orig op
|
|
979 | + herald = ExpectedFunTySyntaxOp 1 orig op
|
|
980 | 980 | |
981 | 981 | go rho_ty (SynType the_ty)
|
982 | 982 | = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
|
... | ... | @@ -1005,7 +1005,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside |
1005 | 1005 | thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
|
1006 | 1006 | ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
|
1007 | 1007 | where
|
1008 | - herald = ExpectedFunTySyntaxOp orig op
|
|
1008 | + herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op
|
|
1009 | 1009 | |
1010 | 1010 | tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
|
1011 | 1011 | -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
|
... | ... | @@ -655,7 +655,7 @@ tcInferOverLit lit@(OverLit { ol_val = val |
655 | 655 | ; let
|
656 | 656 | thing = NameThing from_name
|
657 | 657 | mb_thing = Just thing
|
658 | - herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit)
|
|
658 | + herald = ExpectedFunTyArg 1 thing (HsLit noExtField hs_lit)
|
|
659 | 659 | ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
|
660 | 660 | |
661 | 661 | ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
|
... | ... | @@ -118,7 +118,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty |
118 | 118 | = assertPpr (funBindPrecondition matches) (pprMatches matches) $
|
119 | 119 | do { -- Check that they all have the same no of arguments
|
120 | 120 | arity <- checkArgCounts matches
|
121 | - |
|
121 | + ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches
|
|
122 | 122 | ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
|
123 | 123 | |
124 | 124 | ; (wrap_fun, r)
|
... | ... | @@ -138,7 +138,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty |
138 | 138 | ; return (wrap_fun, r) }
|
139 | 139 | where
|
140 | 140 | mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn
|
141 | - herald = ExpectedFunTyMatches (NameThing fun_name) matches
|
|
141 | + |
|
142 | 142 | |
143 | 143 | funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
|
144 | 144 | funBindPrecondition (MG { mg_alts = L _ alts })
|
... | ... | @@ -698,7 +698,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of |
698 | 698 | -- Note [View patterns and polymorphism]
|
699 | 699 | |
700 | 700 | -- Expression must be a function
|
701 | - ; let herald = ExpectedFunTyViewPat $ unLoc expr
|
|
701 | + ; let herald = ExpectedFunTyViewPat 1 $ unLoc expr
|
|
702 | 702 | ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
|
703 | 703 | <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty
|
704 | 704 | -- See Note [View patterns and polymorphism]
|
... | ... | @@ -17,7 +17,7 @@ import GHC.Hs.Extension |
17 | 17 | import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA )
|
18 | 18 | |
19 | 19 | import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt )
|
20 | -import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin )
|
|
20 | +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt )
|
|
21 | 21 | import GHC.Tc.Utils.TcType ( TcType, TcTyCon )
|
22 | 22 | import GHC.Tc.Zonk.Monad ( ZonkM )
|
23 | 23 | |
... | ... | @@ -120,7 +120,7 @@ data ErrCtxtMsg |
120 | 120 | -- | In a function application.
|
121 | 121 | | FunAppCtxt !FunAppCtxtFunArg !Int
|
122 | 122 | -- | In a function call.
|
123 | - | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int
|
|
123 | + | FunTysCtxt !CtOrigin !Type !Int !Int
|
|
124 | 124 | -- | In the result of a function call.
|
125 | 125 | | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
|
126 | 126 | -- | In the declaration of a type constructor.
|
... | ... | @@ -21,6 +21,7 @@ module GHC.Tc.Types.Origin ( |
21 | 21 | CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
|
22 | 22 | srcCodeOriginCtOrigin,
|
23 | 23 | isVisibleOrigin, toInvisibleOrigin,
|
24 | + updatePositionCtOrigin,
|
|
24 | 25 | pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
|
25 | 26 | isWantedSuperclassOrigin,
|
26 | 27 | ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),
|
... | ... | @@ -45,7 +46,7 @@ module GHC.Tc.Types.Origin ( |
45 | 46 | FRRArrowContext(..), pprFRRArrowContext,
|
46 | 47 | |
47 | 48 | -- ** ExpectedFunTy FixedRuntimeRepOrigin
|
48 | - ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,
|
|
49 | + pprExpectedFunTyHerald,
|
|
49 | 50 | |
50 | 51 | -- * InstanceWhat
|
51 | 52 | InstanceWhat(..), SafeOverlapping
|
... | ... | @@ -82,8 +83,6 @@ import GHC.Utils.Misc( HasDebugCallStack ) |
82 | 83 | import GHC.Types.Unique
|
83 | 84 | import GHC.Types.Unique.Supply
|
84 | 85 | |
85 | -import Language.Haskell.Syntax.Basic (FieldLabelString(..))
|
|
86 | - |
|
87 | 86 | import qualified Data.Kind as Hs
|
88 | 87 | import Data.List.NonEmpty (NonEmpty (..))
|
89 | 88 | import qualified Data.List.NonEmpty as NE
|
... | ... | @@ -653,8 +652,67 @@ data CtOrigin |
653 | 652 | Type -- the instantiated type of the method
|
654 | 653 | | AmbiguityCheckOrigin UserTypeCtxt
|
655 | 654 | | ImplicitLiftOrigin HsImplicitLiftSplice
|
655 | + |
|
656 | 656 | | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin
|
657 | 657 | |
658 | + -- | A rebindable syntax operator is expected to have a function type.
|
|
659 | + --
|
|
660 | + -- Test cases for representation-polymorphism checks:
|
|
661 | + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
|
|
662 | + | forall (p :: Pass)
|
|
663 | + . (OutputableBndrId p)
|
|
664 | + => ExpectedFunTySyntaxOp Int
|
|
665 | + !CtOrigin !(HsExpr (GhcPass p))
|
|
666 | + -- ^ rebindable syntax operator
|
|
667 | + |
|
668 | + -- | A view pattern must have a function type.
|
|
669 | + --
|
|
670 | + -- Test cases for representation-polymorphism checks:
|
|
671 | + -- RepPolyBinder
|
|
672 | + | ExpectedFunTyViewPat Int
|
|
673 | + !(HsExpr GhcRn)
|
|
674 | + -- ^ function used in the view pattern
|
|
675 | + |
|
676 | + -- | Need to be able to extract an argument type from a function type.
|
|
677 | + --
|
|
678 | + -- Test cases for representation-polymorphism checks:
|
|
679 | + -- RepPolyApp
|
|
680 | + | forall (p :: Pass)
|
|
681 | + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
|
|
682 | + Int
|
|
683 | + -- ^ Argument number
|
|
684 | + !TypedThing
|
|
685 | + -- ^ function
|
|
686 | + !(HsExpr (GhcPass p))
|
|
687 | + -- ^ argument
|
|
688 | + |
|
689 | + -- | Ensure that a function defined by equations indeed has a function type
|
|
690 | + -- with the appropriate number of arguments.
|
|
691 | + --
|
|
692 | + -- Test cases for representation-polymorphism checks:
|
|
693 | + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern
|
|
694 | + | ExpectedFunTyMatches Int
|
|
695 | + !TypedThing
|
|
696 | + -- ^ name of the function
|
|
697 | + !(MatchGroup GhcRn (LHsExpr GhcRn))
|
|
698 | + -- ^ equations
|
|
699 | + |
|
700 | + -- | Ensure that a lambda abstraction has a function type.
|
|
701 | + --
|
|
702 | + -- Test cases for representation-polymorphism checks:
|
|
703 | + -- RepPolyLambda, RepPolyMatch
|
|
704 | + | ExpectedFunTyLam HsLamVariant
|
|
705 | + !(HsExpr GhcRn)
|
|
706 | + -- ^ the entire lambda-case expression
|
|
707 | + |
|
708 | +updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin
|
|
709 | +updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e
|
|
710 | +updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e
|
|
711 | +updatePositionCtOrigin i (ExpectedFunTyArg _ t e) = ExpectedFunTyArg i t e
|
|
712 | +updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e
|
|
713 | +updatePositionCtOrigin _ c = c
|
|
714 | + |
|
715 | + |
|
658 | 716 | data NonLinearPatternReason
|
659 | 717 | = LazyPatternReason
|
660 | 718 | | GeneralisedPatternReason
|
... | ... | @@ -727,7 +785,8 @@ lexprCtOrigin (L _ e) = exprCtOrigin e |
727 | 785 | |
728 | 786 | exprCtOrigin :: HsExpr GhcRn -> CtOrigin
|
729 | 787 | exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name
|
730 | -exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
|
|
788 | +exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e)
|
|
789 | + -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
|
|
731 | 790 | exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
|
732 | 791 | exprCtOrigin (ExplicitList {}) = ListOrigin
|
733 | 792 | exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
|
... | ... | @@ -739,7 +798,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 |
739 | 798 | exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
|
740 | 799 | exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
|
741 | 800 | exprCtOrigin (HsPar _ e) = lexprCtOrigin e
|
742 | -exprCtOrigin (HsProjection _ p) = GetFieldOrigin ((field_label . unLoc . dfoLabel . NE.head . NE.reverse) p)
|
|
801 | +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
|
|
743 | 802 | exprCtOrigin (SectionL _ _ _) = SectionOrigin
|
744 | 803 | exprCtOrigin (SectionR _ _ _) = SectionOrigin
|
745 | 804 | exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
|
... | ... | @@ -802,7 +861,7 @@ pprCtOrigin (ExpansionOrigin o) |
802 | 861 | where what :: SDoc
|
803 | 862 | what = case o of
|
804 | 863 | OrigStmt{} -> text "a do statement"
|
805 | - OrigExpr e -> text "an expression" <+> ppr e
|
|
864 | + OrigExpr e -> pprCtO (exprCtOrigin e)
|
|
806 | 865 | OrigPat p -> text "a pattern" <+> ppr p
|
807 | 866 | |
808 | 867 | pprCtOrigin (GivenSCOrigin sk d blk)
|
... | ... | @@ -917,9 +976,38 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) |
917 | 976 | = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat))
|
918 | 977 | 2 (pprNonLinearPatternReason reason)
|
919 | 978 | |
979 | +pprCtOrigin (ExpectedFunTySyntaxOp i orig op) =
|
|
980 | + vcat [ sep [ the_arg_of i
|
|
981 | + , text "the rebindable syntax operator"
|
|
982 | + , quotes (ppr op) ]
|
|
983 | + , nest 2 (ppr orig) ]
|
|
984 | +pprCtOrigin (ExpectedFunTyViewPat i expr) =
|
|
985 | + vcat [ the_arg_of i <+> text "the view pattern"
|
|
986 | + , nest 2 (ppr expr) ]
|
|
987 | +pprCtOrigin (ExpectedFunTyArg i fun arg) =
|
|
988 | + sep [ text "The" <+> speakNth i <+> text "argument"
|
|
989 | + , quotes (ppr arg)
|
|
990 | + , text "of"
|
|
991 | + , quotes (ppr fun) ]
|
|
992 | +pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts }))
|
|
993 | + | null alts
|
|
994 | + = the_arg_of i <+> quotes (ppr fun)
|
|
995 | + | otherwise
|
|
996 | + = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
|
|
997 | + <+> text "for" <+> quotes (ppr fun)
|
|
998 | +pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant
|
|
999 | + |
|
920 | 1000 | pprCtOrigin simple_origin
|
921 | 1001 | = ctoHerald <+> pprCtO simple_origin
|
922 | 1002 | |
1003 | + |
|
1004 | +the_arg_of :: Int -> SDoc
|
|
1005 | +the_arg_of i = text "The" <+> speakNth i <+> text "argument of"
|
|
1006 | + |
|
1007 | +binder_of :: SDoc -> SDoc
|
|
1008 | +binder_of what = text "The binder of the" <+> what <+> text "expression"
|
|
1009 | + |
|
1010 | + |
|
923 | 1011 | -- | Short one-liners
|
924 | 1012 | pprCtO :: HasDebugCallStack => CtOrigin -> SDoc
|
925 | 1013 | pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)]
|
... | ... | @@ -945,7 +1033,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" |
945 | 1033 | pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration"
|
946 | 1034 | pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
|
947 | 1035 | pprCtO DefaultOrigin = text "a 'default' declaration"
|
948 | -pprCtO DoStmtOrigin = text "a do statement"
|
|
1036 | +pprCtO DoStmtOrigin = text "a do statement"
|
|
949 | 1037 | pprCtO MCompOrigin = text "a statement in a monad comprehension"
|
950 | 1038 | pprCtO ProcOrigin = text "a proc expression"
|
951 | 1039 | pprCtO ArrowCmdOrigin = text "an arrow command"
|
... | ... | @@ -990,7 +1078,13 @@ pprCtO (ImpedanceMatching {}) = text "combining required constraints" |
990 | 1078 | pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
|
991 | 1079 | pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)]
|
992 | 1080 | pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement"
|
993 | -pprCtO (ExpansionOrigin (OrigExpr{})) = text "an expression"
|
|
1081 | +pprCtO (ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ f)))) = hsep [text "selecting the field", quotes (ppr f)]
|
|
1082 | +pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e
|
|
1083 | +pprCtO (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator"
|
|
1084 | +pprCtO (ExpectedFunTyViewPat{}) = text "a view pattern"
|
|
1085 | +pprCtO (ExpectedFunTyArg{}) = text "a funtion head"
|
|
1086 | +pprCtO (ExpectedFunTyMatches{}) = text "a match statement"
|
|
1087 | +pprCtO (ExpectedFunTyLam{}) = text "a lambda expression"
|
|
994 | 1088 | |
995 | 1089 | |
996 | 1090 | pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
|
... | ... | @@ -1204,7 +1298,7 @@ data FixedRuntimeRepContext |
1204 | 1298 | --
|
1205 | 1299 | -- See 'ExpectedFunTyOrigin' for more details.
|
1206 | 1300 | | FRRExpectedFunTy
|
1207 | - !ExpectedFunTyOrigin
|
|
1301 | + !CtOrigin -- !ExpectedFunTyOrigin
|
|
1208 | 1302 | !Int
|
1209 | 1303 | -- ^ argument position (1-indexed)
|
1210 | 1304 | |
... | ... | @@ -1285,8 +1379,8 @@ pprFixedRuntimeRepContext FRRBindStmtGuard |
1285 | 1379 | = sep [ text "The body of the bind statement" ]
|
1286 | 1380 | pprFixedRuntimeRepContext (FRRArrow arrowContext)
|
1287 | 1381 | = pprFRRArrowContext arrowContext
|
1288 | -pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos)
|
|
1289 | - = pprExpectedFunTyOrigin funTyOrig arg_pos
|
|
1382 | +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _)
|
|
1383 | + = pprCtOrigin funTyOrig
|
|
1290 | 1384 | |
1291 | 1385 | instance Outputable FixedRuntimeRepContext where
|
1292 | 1386 | ppr = pprFixedRuntimeRepContext
|
... | ... | @@ -1439,102 +1533,24 @@ instance Outputable FRRArrowContext where |
1439 | 1533 | -- Uses 'pprExpectedFunTyOrigin'.
|
1440 | 1534 | -- See 'FixedRuntimeRepContext' for the situations in which
|
1441 | 1535 | -- representation-polymorphism checks are performed.
|
1442 | -data ExpectedFunTyOrigin
|
|
1443 | - |
|
1444 | - -- | A rebindable syntax operator is expected to have a function type.
|
|
1445 | - --
|
|
1446 | - -- Test cases for representation-polymorphism checks:
|
|
1447 | - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
|
|
1448 | - = forall (p :: Pass)
|
|
1449 | - . (OutputableBndrId p)
|
|
1450 | - => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))
|
|
1451 | - -- ^ rebindable syntax operator
|
|
1452 | - |
|
1453 | - -- | A view pattern must have a function type.
|
|
1454 | - --
|
|
1455 | - -- Test cases for representation-polymorphism checks:
|
|
1456 | - -- RepPolyBinder
|
|
1457 | - | ExpectedFunTyViewPat
|
|
1458 | - !(HsExpr GhcRn)
|
|
1459 | - -- ^ function used in the view pattern
|
|
1460 | - |
|
1461 | - -- | Need to be able to extract an argument type from a function type.
|
|
1462 | - --
|
|
1463 | - -- Test cases for representation-polymorphism checks:
|
|
1464 | - -- RepPolyApp
|
|
1465 | - | forall (p :: Pass)
|
|
1466 | - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
|
|
1467 | - !TypedThing
|
|
1468 | - -- ^ function
|
|
1469 | - !(HsExpr (GhcPass p))
|
|
1470 | - -- ^ argument
|
|
1471 | - |
|
1472 | - -- | Ensure that a function defined by equations indeed has a function type
|
|
1473 | - -- with the appropriate number of arguments.
|
|
1474 | - --
|
|
1475 | - -- Test cases for representation-polymorphism checks:
|
|
1476 | - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern
|
|
1477 | - | ExpectedFunTyMatches
|
|
1478 | - !TypedThing
|
|
1479 | - -- ^ name of the function
|
|
1480 | - !(MatchGroup GhcRn (LHsExpr GhcRn))
|
|
1481 | - -- ^ equations
|
|
1482 | - |
|
1483 | - -- | Ensure that a lambda abstraction has a function type.
|
|
1484 | - --
|
|
1485 | - -- Test cases for representation-polymorphism checks:
|
|
1486 | - -- RepPolyLambda, RepPolyMatch
|
|
1487 | - | ExpectedFunTyLam HsLamVariant
|
|
1488 | - !(HsExpr GhcRn)
|
|
1489 | - -- ^ the entire lambda-case expression
|
|
1490 | - |
|
1491 | -pprExpectedFunTyOrigin :: ExpectedFunTyOrigin
|
|
1492 | - -> Int -- ^ argument position (starting at 1)
|
|
1493 | - -> SDoc
|
|
1494 | -pprExpectedFunTyOrigin funTy_origin i =
|
|
1495 | - case funTy_origin of
|
|
1496 | - ExpectedFunTySyntaxOp orig op ->
|
|
1497 | - vcat [ sep [ the_arg_of
|
|
1498 | - , text "the rebindable syntax operator"
|
|
1499 | - , quotes (ppr op) ]
|
|
1500 | - , nest 2 (ppr orig) ]
|
|
1501 | - ExpectedFunTyViewPat expr ->
|
|
1502 | - vcat [ the_arg_of <+> text "the view pattern"
|
|
1503 | - , nest 2 (ppr expr) ]
|
|
1504 | - ExpectedFunTyArg fun arg ->
|
|
1505 | - sep [ text "The argument"
|
|
1506 | - , quotes (ppr arg)
|
|
1507 | - , text "of"
|
|
1508 | - , quotes (ppr fun) ]
|
|
1509 | - ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })
|
|
1510 | - | null alts
|
|
1511 | - -> the_arg_of <+> quotes (ppr fun)
|
|
1512 | - | otherwise
|
|
1513 | - -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
|
|
1514 | - <+> text "for" <+> quotes (ppr fun)
|
|
1515 | - ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant
|
|
1516 | - where
|
|
1517 | - the_arg_of :: SDoc
|
|
1518 | - the_arg_of = text "The" <+> speakNth i <+> text "argument of"
|
|
1519 | 1536 | |
1520 | - binder_of :: SDoc -> SDoc
|
|
1521 | - binder_of what = text "The binder of the" <+> what <+> text "expression"
|
|
1522 | 1537 | |
1523 | -pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
|
|
1538 | +pprExpectedFunTyHerald :: CtOrigin -> SDoc
|
|
1524 | 1539 | pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
|
1525 | 1540 | = text "This rebindable syntax expects a function with"
|
1526 | 1541 | pprExpectedFunTyHerald (ExpectedFunTyViewPat {})
|
1527 | 1542 | = text "A view pattern expression expects"
|
1528 | -pprExpectedFunTyHerald (ExpectedFunTyArg fun _)
|
|
1543 | +pprExpectedFunTyHerald (ExpectedFunTyArg _ fun _)
|
|
1529 | 1544 | = sep [ text "The function" <+> quotes (ppr fun)
|
1530 | 1545 | , text "is applied to" ]
|
1531 | -pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))
|
|
1546 | +pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts }))
|
|
1532 | 1547 | = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts
|
1533 | 1548 | pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)
|
1534 | 1549 | = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression"
|
1535 | 1550 | <+> quotes (pprSetDepth (PartWay 1) (ppr expr))
|
1536 | 1551 | -- The pprSetDepth makes the lambda abstraction print briefly
|
1537 | 1552 | , text "has" ]
|
1553 | +pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig
|
|
1538 | 1554 | |
1539 | 1555 | {- *******************************************************************
|
1540 | 1556 | * *
|
... | ... | @@ -135,7 +135,7 @@ import Data.Traversable (for) |
135 | 135 | --
|
136 | 136 | -- See Note [Return arguments with a fixed RuntimeRep].
|
137 | 137 | matchActualFunTy
|
138 | - :: ExpectedFunTyOrigin
|
|
138 | + :: CtOrigin
|
|
139 | 139 | -- ^ See Note [Herald for matchExpectedFunTys]
|
140 | 140 | -> Maybe TypedThing
|
141 | 141 | -- ^ The thing with type TcSigmaType
|
... | ... | @@ -174,7 +174,7 @@ matchActualFunTy herald mb_thing err_info fun_ty |
174 | 174 | |
175 | 175 | go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
|
176 | 176 | = assert (isVisibleFunArg af) $
|
177 | - do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty
|
|
177 | + do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty
|
|
178 | 178 | ; return (idHsWrapper, Scaled w arg_ty, res_ty) }
|
179 | 179 | |
180 | 180 | go ty@(TyVarTy tv)
|
... | ... | @@ -241,7 +241,7 @@ Ugh! |
241 | 241 | -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep
|
242 | 242 | -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
|
243 | 243 | -- See Note [Return arguments with a fixed RuntimeRep].
|
244 | -matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]
|
|
244 | +matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys]
|
|
245 | 245 | -> CtOrigin
|
246 | 246 | -> Arity
|
247 | 247 | -> TcSigmaType
|
... | ... | @@ -776,7 +776,7 @@ Example: |
776 | 776 | -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
|
777 | 777 | -- See Note [Return arguments with a fixed RuntimeRep].
|
778 | 778 | matchExpectedFunTys :: forall a.
|
779 | - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]
|
|
779 | + CtOrigin -- See Note [Herald for matchExpectedFunTys]
|
|
780 | 780 | -> UserTypeCtxt
|
781 | 781 | -> VisArity
|
782 | 782 | -> ExpSigmaType
|
... | ... | @@ -852,7 +852,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside |
852 | 852 | , ft_arg = arg_ty, ft_res = res_ty })
|
853 | 853 | = assert (isVisibleFunArg af) $
|
854 | 854 | do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc
|
855 | - ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
|
|
855 | + ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty
|
|
856 | 856 | ; (wrap_res, result) <- check (n_req - 1)
|
857 | 857 | (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys)
|
858 | 858 | res_ty
|
... | ... | @@ -905,19 +905,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside |
905 | 905 | ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty
|
906 | 906 | ; return (mkWpCastN co, result) }
|
907 | 907 | |
908 | -new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR)
|
|
908 | +new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR)
|
|
909 | 909 | new_infer_arg_ty herald arg_pos -- position for error messages only
|
910 | 910 | = do { mult <- newFlexiTyVarTy multiplicityTy
|
911 | - ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
|
|
911 | + ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos)
|
|
912 | 912 | ; return (mkScaled mult inf_hole) }
|
913 | 913 | |
914 | -new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)
|
|
914 | +new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType)
|
|
915 | 915 | new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg
|
916 | 916 | = do { mult <- newFlexiTyVarTy multiplicityTy
|
917 | - ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)
|
|
917 | + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos)
|
|
918 | 918 | ; return (mkScaled mult arg_ty) }
|
919 | 919 | |
920 | -mkFunTysMsg :: ExpectedFunTyOrigin
|
|
920 | +mkFunTysMsg :: CtOrigin
|
|
921 | 921 | -> (VisArity, TcType)
|
922 | 922 | -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)
|
923 | 923 | -- See Note [Reporting application arity errors]
|