Simon Peyton Jones pushed to branch wip/T26369 at Glasgow Haskell Compiler / GHC
Commits:
-
2897da11
by Simon Peyton Jones at 2025-09-04T12:58:10+01:00
22 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion.hs-boot
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Reduction.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
Changes:
... | ... | @@ -47,7 +47,7 @@ module GHC.Core.Coercion ( |
47 | 47 | mkProofIrrelCo,
|
48 | 48 | downgradeRole,
|
49 | 49 | mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
|
50 | - mkKindCo,
|
|
50 | + mkKindCo, forAllCoKindCo,
|
|
51 | 51 | castCoercionKind, castCoercionKind1, castCoercionKind2,
|
52 | 52 | |
53 | 53 | -- ** Decomposition
|
... | ... | @@ -66,11 +66,14 @@ module GHC.Core.Coercion ( |
66 | 66 | tyConRoleListX, tyConRoleListRepresentational, funRole,
|
67 | 67 | pickLR,
|
68 | 68 | |
69 | - isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
|
|
70 | - isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,
|
|
69 | + isReflKindCo,isReflKindMCo,
|
|
70 | + isReflCo, isReflCo_maybe,
|
|
71 | + isReflexiveMCo, isReflexiveCo, isReflexiveCo_maybe,
|
|
72 | + isReflCoVar_maybe, mkGReflLeftMCo, mkGReflRightMCo,
|
|
71 | 73 | mkCoherenceRightMCo,
|
72 | 74 | |
73 | - coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,
|
|
75 | + coToMCo, kindCoToMKindCo,
|
|
76 | + mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,
|
|
74 | 77 | mkFunResMCo, mkPiMCos,
|
75 | 78 | isReflMCo, checkReflexiveMCo,
|
76 | 79 | |
... | ... | @@ -85,7 +88,7 @@ module GHC.Core.Coercion ( |
85 | 88 | -- ** Substitution
|
86 | 89 | CvSubstEnv, emptyCvSubstEnv,
|
87 | 90 | lookupCoVar,
|
88 | - substCo, substCos, substCoVar, substCoVars, substCoWith,
|
|
91 | + substCo, substCos, substCoVar, substCoVars, substCoWithInScope,
|
|
89 | 92 | substCoVarBndr,
|
90 | 93 | extendTvSubstAndInScope, getCvSubstEnv,
|
91 | 94 | |
... | ... | @@ -317,23 +320,23 @@ coToMCo :: Coercion -> MCoercion |
317 | 320 | coToMCo co | isReflCo co = MRefl
|
318 | 321 | | otherwise = MCo co
|
319 | 322 | |
323 | +kindCoToMKindCo :: KindCoercion -> KindMCoercion
|
|
324 | +-- Convert a KindCoercion to a KindMCoercion,
|
|
325 | +-- coToMCo doesn't eliminate GRefl, but kindCoToMCo can
|
|
326 | +-- See Note [KindCoercion]
|
|
327 | +kindCoToMKindCo co | isReflKindCo co = MRefl
|
|
328 | + | otherwise = MCo co
|
|
329 | + |
|
320 | 330 | checkReflexiveMCo :: MCoercion -> MCoercion
|
321 | 331 | checkReflexiveMCo MRefl = MRefl
|
322 | 332 | checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl
|
323 | 333 | | otherwise = MCo co
|
324 | 334 | |
325 | --- | Tests if this MCoercion is obviously generalized reflexive
|
|
326 | --- Guaranteed to work very quickly.
|
|
327 | -isGReflMCo :: MCoercion -> Bool
|
|
328 | -isGReflMCo MRefl = True
|
|
329 | -isGReflMCo (MCo co) | isGReflCo co = True
|
|
330 | -isGReflMCo _ = False
|
|
331 | - |
|
332 | 335 | -- | Make a generalized reflexive coercion
|
333 | 336 | mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
|
334 | 337 | mkGReflCo r ty mco
|
335 | - | isGReflMCo mco = if r == Nominal then Refl ty
|
|
336 | - else GRefl r ty MRefl
|
|
338 | + | isReflKindMCo mco = if r == Nominal then Refl ty
|
|
339 | + else GRefl r ty MRefl
|
|
337 | 340 | | otherwise
|
338 | 341 | = -- I'd like to have this assert, but sadly it's not true during type
|
339 | 342 | -- inference because the types are not fully zonked
|
... | ... | @@ -565,10 +568,13 @@ splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) |
565 | 568 | splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)
|
566 | 569 | splitFunCo_maybe _ = Nothing
|
567 | 570 | |
568 | -splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
|
|
571 | +splitForAllCo_maybe :: Coercion
|
|
572 | + -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
|
|
573 | +-- You might think that this function should return KindMCoercion (rather
|
|
574 | +-- than a KindCoercion), but in fact most of the clients want a KindCoercion.
|
|
569 | 575 | splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR
|
570 | - , fco_kind = k_co, fco_body = co })
|
|
571 | - = Just (tv, vL, vR, k_co, co)
|
|
576 | + , fco_kind = k_mco, fco_body = co })
|
|
577 | + = Just (tv, vL, vR, forAllCoKindCo tv k_mco, co)
|
|
572 | 578 | splitForAllCo_maybe co
|
573 | 579 | | Just (ty, r) <- isReflCo_maybe co
|
574 | 580 | , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty
|
... | ... | @@ -576,7 +582,8 @@ splitForAllCo_maybe co |
576 | 582 | splitForAllCo_maybe _ = Nothing
|
577 | 583 | |
578 | 584 | -- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder
|
579 | -splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
|
|
585 | +splitForAllCo_ty_maybe :: Coercion
|
|
586 | + -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
|
|
580 | 587 | splitForAllCo_ty_maybe co
|
581 | 588 | | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co
|
582 | 589 | , isTyVar tv
|
... | ... | @@ -584,7 +591,8 @@ splitForAllCo_ty_maybe co |
584 | 591 | splitForAllCo_ty_maybe _ = Nothing
|
585 | 592 | |
586 | 593 | -- | Like 'splitForAllCo_maybe', but only returns Just for covar binder
|
587 | -splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
|
|
594 | +splitForAllCo_co_maybe :: Coercion
|
|
595 | + -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
|
|
588 | 596 | splitForAllCo_co_maybe co
|
589 | 597 | | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co
|
590 | 598 | , isCoVar cv
|
... | ... | @@ -676,34 +684,50 @@ isReflCoVar_maybe cv |
676 | 684 | | otherwise
|
677 | 685 | = Nothing
|
678 | 686 | |
679 | --- | Tests if this coercion is obviously a generalized reflexive coercion.
|
|
687 | +-- | Tests whether this is a "kind coercion":
|
|
688 | +-- that is, Nominal and between two types of kind @Type@.
|
|
689 | +-- See Note [KindCoercion] in GHC.Core.TyCo.Rep
|
|
690 | +isKindCo :: Coercion -> Bool
|
|
691 | +isKindCo co
|
|
692 | + = role == Nominal && isLiftedTypeKind kk1 && isLiftedTypeKind kk2
|
|
693 | + where
|
|
694 | + (Pair kk1 kk2, role) = coercionKindRole co
|
|
695 | + |
|
696 | +-- | Tests if this /kind/ coercion is Refl
|
|
697 | +-- Guaranteed to work very quickly.
|
|
698 | +-- PRECONDITION: the argument is a KindCoercion
|
|
699 | +-- So if it sees (GRefl k (MCo kk)) :: k ~ (k |> kk)
|
|
700 | +-- then we know that kk must be reflexive.
|
|
701 | +-- And hence if co = GRefl {} then it is equivalent to Refl,
|
|
702 | +-- because GRefl N ty MRefl = Refl ty
|
|
703 | +-- so we return True
|
|
704 | +-- See Note [KindCoercion] in GHC.Core.TyCo.Rep
|
|
705 | +isReflKindCo :: HasDebugCallStack => KindCoercion -> Bool
|
|
706 | +isReflKindCo co@(GRefl {}) = assertPpr (isKindCo co) (ppr co) $
|
|
707 | + True
|
|
708 | +isReflKindCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl
|
|
709 | +isReflKindCo _ = False
|
|
710 | + |
|
711 | +-- | Tests if this /kind/ MCoercion is obviously generalized reflexive
|
|
680 | 712 | -- Guaranteed to work very quickly.
|
681 | -isGReflCo :: Coercion -> Bool
|
|
682 | -isGReflCo (GRefl{}) = True
|
|
683 | -isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl
|
|
684 | -isGReflCo _ = False
|
|
713 | +isReflKindMCo :: KindMCoercion -> Bool
|
|
714 | +isReflKindMCo MRefl = True
|
|
715 | +isReflKindMCo (MCo co) = isReflKindCo co
|
|
685 | 716 | |
686 | 717 | -- | Tests if this coercion is obviously reflexive. Guaranteed to work
|
687 | 718 | -- very quickly. Sometimes a coercion can be reflexive, but not obviously
|
688 | 719 | -- so. c.f. 'isReflexiveCo'
|
689 | 720 | isReflCo :: Coercion -> Bool
|
690 | 721 | isReflCo (Refl{}) = True
|
691 | -isReflCo (GRefl _ _ mco) | isGReflMCo mco = True
|
|
722 | +isReflCo (GRefl _ _ mco) | isReflKindMCo mco = True
|
|
692 | 723 | isReflCo _ = False
|
693 | 724 | |
694 | --- | Returns the type coerced if this coercion is a generalized reflexive
|
|
695 | --- coercion. Guaranteed to work very quickly.
|
|
696 | -isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
|
|
697 | -isGReflCo_maybe (GRefl r ty _) = Just (ty, r)
|
|
698 | -isGReflCo_maybe (Refl ty) = Just (ty, Nominal)
|
|
699 | -isGReflCo_maybe _ = Nothing
|
|
700 | - |
|
701 | 725 | -- | Returns the type coerced if this coercion is reflexive. Guaranteed
|
702 | 726 | -- to work very quickly. Sometimes a coercion can be reflexive, but not
|
703 | 727 | -- obviously so. c.f. 'isReflexiveCo_maybe'
|
704 | 728 | isReflCo_maybe :: Coercion -> Maybe (Type, Role)
|
705 | 729 | isReflCo_maybe (Refl ty) = Just (ty, Nominal)
|
706 | -isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
|
|
730 | +isReflCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r)
|
|
707 | 731 | isReflCo_maybe _ = Nothing
|
708 | 732 | |
709 | 733 | -- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
|
... | ... | @@ -711,11 +735,15 @@ isReflCo_maybe _ = Nothing |
711 | 735 | isReflexiveCo :: Coercion -> Bool
|
712 | 736 | isReflexiveCo = isJust . isReflexiveCo_maybe
|
713 | 737 | |
738 | +isReflexiveMCo :: MCoercion -> Bool
|
|
739 | +isReflexiveMCo MRefl = True
|
|
740 | +isReflexiveMCo (MCo co) = isReflexiveCo co
|
|
741 | + |
|
714 | 742 | -- | Extracts the coerced type from a reflexive coercion. This potentially
|
715 | 743 | -- walks over the entire coercion, so avoid doing this in a loop.
|
716 | 744 | isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)
|
717 | 745 | isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)
|
718 | -isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
|
|
746 | +isReflexiveCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r)
|
|
719 | 747 | isReflexiveCo_maybe co
|
720 | 748 | | ty1 `eqType` ty2
|
721 | 749 | = Just (ty1, r)
|
... | ... | @@ -723,6 +751,10 @@ isReflexiveCo_maybe co |
723 | 751 | = Nothing
|
724 | 752 | where (Pair ty1 ty2, r) = coercionKindRole co
|
725 | 753 | |
754 | +forAllCoKindCo :: TyCoVar -> KindMCoercion -> KindCoercion
|
|
755 | +-- Get the kind coercion from a ForAllCo
|
|
756 | +forAllCoKindCo _ (MCo co) = co
|
|
757 | +forAllCoKindCo tcv MRefl = mkNomReflCo (varType tcv)
|
|
726 | 758 | |
727 | 759 | {-
|
728 | 760 | %************************************************************************
|
... | ... | @@ -939,10 +971,11 @@ mkAppCos co1 cos = foldl' mkAppCo co1 cos |
939 | 971 | |
940 | 972 | |
941 | 973 | -- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.
|
942 | -mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
|
|
974 | +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
|
|
975 | + -> KindMCoercion -> Coercion -> Coercion
|
|
943 | 976 | mkForAllCo v visL visR kind_co co
|
944 | 977 | | Just (ty, r) <- isReflCo_maybe co
|
945 | - , isReflCo kind_co
|
|
978 | + , isReflMCo kind_co
|
|
946 | 979 | , visL `eqForAllVis` visR
|
947 | 980 | = mkReflCo r (mkTyCoForAllTy v visL ty)
|
948 | 981 | |
... | ... | @@ -955,8 +988,7 @@ mkForAllCo v visL visR kind_co co |
955 | 988 | mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion
|
956 | 989 | mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs
|
957 | 990 | where
|
958 | - go (Bndr tv vis)
|
|
959 | - = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv))
|
|
991 | + go (Bndr tv vis) = mkForAllCo tv coreTyLamForAllTyFlag vis MRefl
|
|
960 | 992 | |
961 | 993 | -- | Make a Coercion quantified over a type/coercion variable;
|
962 | 994 | -- the variable has the same kind and visibility in both sides of the coercion
|
... | ... | @@ -967,29 +999,30 @@ mkHomoForAllCos vs orig_co |
967 | 999 | | otherwise
|
968 | 1000 | = foldr go orig_co vs
|
969 | 1001 | where
|
970 | - go (Bndr var vis) co
|
|
971 | - = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co
|
|
1002 | + go :: ForAllTyBinder -> Coercion -> Coercion
|
|
1003 | + go (Bndr var vis) = mkForAllCo_NoRefl var vis vis MRefl
|
|
972 | 1004 | |
973 | 1005 | -- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;
|
974 | 1006 | -- the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)
|
975 | 1007 | -- The kind of the tycovar should be the left-hand kind of the kind coercion.
|
976 | -mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
|
|
1008 | +mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag
|
|
1009 | + -> KindMCoercion -> Coercion -> Coercion
|
|
977 | 1010 | mkForAllCo_NoRefl tcv visL visR kind_co co
|
978 | 1011 | = assertGoodForAllCo tcv visL visR kind_co co $
|
979 | - assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $
|
|
1012 | + assertPpr (not (isReflCo co && isReflMCo kind_co && visL == visR)) (ppr co) $
|
|
980 | 1013 | ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
|
981 | 1014 | , fco_kind = kind_co, fco_body = co }
|
982 | 1015 | |
983 | 1016 | assertGoodForAllCo :: HasDebugCallStack
|
984 | - => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
|
|
985 | - -> CoercionN -> Coercion -> a -> a
|
|
1017 | + => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
|
|
1018 | + -> KindMCoercion -> Coercion -> a -> a
|
|
986 | 1019 | -- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep
|
987 | 1020 | assertGoodForAllCo tcv visL visR kind_co co
|
988 | 1021 | | isTyVar tcv
|
989 | - = assertPpr (tcv_type `eqType` kind_co_lkind) doc
|
|
1022 | + = assertPpr tcv_kind_co_agree doc
|
|
990 | 1023 | |
991 | 1024 | | otherwise
|
992 | - = assertPpr (tcv_type `eqType` kind_co_lkind) doc
|
|
1025 | + = assertPpr tcv_kind_co_agree doc
|
|
993 | 1026 | -- The kind of the tycovar should be the left-hand kind of the kind coercion.
|
994 | 1027 | . assertPpr (almostDevoidCoVarOfCo tcv co) doc
|
995 | 1028 | -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep
|
... | ... | @@ -998,13 +1031,17 @@ assertGoodForAllCo tcv visL visR kind_co co |
998 | 1031 | -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep
|
999 | 1032 | where
|
1000 | 1033 | tcv_type = varType tcv
|
1001 | - kind_co_lkind = coercionLKind kind_co
|
|
1034 | + tcv_kind_co_agree = case kind_co of
|
|
1035 | + MRefl -> True
|
|
1036 | + MCo co -> tcv_type `eqType` coercionLKind co
|
|
1002 | 1037 | |
1003 | 1038 | doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type
|
1004 | 1039 | , text "Vis:" <+> ppr visL <+> ppr visR
|
1005 | - , text "kind_co:" <+> ppr kind_co
|
|
1006 | - , text "kind_co_lkind" <+> ppr kind_co_lkind
|
|
1040 | + , text "kind_co:" <+> pp_kind_co
|
|
1007 | 1041 | , text "body_co" <+> ppr co ]
|
1042 | + pp_kind_co = case kind_co of
|
|
1043 | + MRefl -> text "MRefl"
|
|
1044 | + MCo co -> ppr co <+> dcolon <+> ppr (coercionKind co)
|
|
1008 | 1045 | |
1009 | 1046 | |
1010 | 1047 | mkNakedForAllCo :: TyVar -- Never a CoVar
|
... | ... | @@ -1024,7 +1061,7 @@ mkNakedForAllCo tv visL visR kind_co co |
1024 | 1061 | = mkReflCo r (mkForAllTy (Bndr tv visL) ty)
|
1025 | 1062 | | otherwise
|
1026 | 1063 | = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
|
1027 | - , fco_kind = kind_co, fco_body = co }
|
|
1064 | + , fco_kind = MCo kind_co, fco_body = co }
|
|
1028 | 1065 | |
1029 | 1066 | |
1030 | 1067 | mkCoVarCo :: CoVar -> Coercion
|
... | ... | @@ -1149,7 +1186,7 @@ mkSymCo co | isReflCo co = co |
1149 | 1186 | mkSymCo (SymCo co) = co
|
1150 | 1187 | mkSymCo (SubCo (SymCo co)) = SubCo co
|
1151 | 1188 | mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co })
|
1152 | - | isReflCo kco = co { fco_body = mkSymCo body_co }
|
|
1189 | + | isReflMCo kco = co { fco_body = mkSymCo body_co }
|
|
1153 | 1190 | mkSymCo co = SymCo co
|
1154 | 1191 | |
1155 | 1192 | -- | mkTransCo creates a new 'Coercion' by composing the two
|
... | ... | @@ -1193,8 +1230,8 @@ mkSelCo_maybe cs co |
1193 | 1230 | go cs co
|
1194 | 1231 | where
|
1195 | 1232 | |
1196 | - go SelForAll (ForAllCo { fco_kind = kind_co })
|
|
1197 | - = Just kind_co
|
|
1233 | + go SelForAll (ForAllCo { fco_tcv = tcv, fco_kind = kind_co })
|
|
1234 | + = Just (forAllCoKindCo tcv kind_co)
|
|
1198 | 1235 | -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
|
1199 | 1236 | -- then (nth SelForAll co :: k1 ~N k2)
|
1200 | 1237 | -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
|
... | ... | @@ -1312,46 +1349,45 @@ mkInstCo :: Coercion -> CoercionN -> Coercion |
1312 | 1349 | mkInstCo co_fun co_arg
|
1313 | 1350 | | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun
|
1314 | 1351 | , Just (arg, _) <- isReflCo_maybe co_arg
|
1352 | + , let in_scope = mkInScopeSet $
|
|
1353 | + tyCoVarsOfType arg `unionVarSet` tyCoVarsOfCo body_co
|
|
1354 | + subst = extendTCvSubst (mkEmptySubst in_scope) tcv arg
|
|
1315 | 1355 | = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $
|
1316 | 1356 | -- If the arg is Refl, then kind_co must be reflexive too
|
1317 | - substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co
|
|
1357 | + substCo subst body_co
|
|
1318 | 1358 | mkInstCo co arg = InstCo co arg
|
1319 | 1359 | |
1320 | 1360 | -- | Given @ty :: k1@, @co :: k1 ~ k2@,
|
1321 | 1361 | -- produces @co' :: ty ~r (ty |> co)@
|
1322 | -mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion
|
|
1362 | +mkGReflRightCo :: Role -> Type -> KindCoercion -> Coercion
|
|
1323 | 1363 | mkGReflRightCo r ty co
|
1324 | - | isGReflCo co = mkReflCo r ty
|
|
1325 | - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
|
|
1326 | - -- instead of @isReflCo@
|
|
1327 | - | otherwise = mkGReflMCo r ty co
|
|
1364 | + | isReflKindCo co = mkReflCo r ty -- Homo (tested) AND nominal (I promise) => Refl
|
|
1365 | + | otherwise = mkGReflMCo r ty co
|
|
1328 | 1366 | |
1329 | 1367 | -- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,
|
1330 | 1368 | -- produces @co' :: (ty |> co) ~r ty@
|
1331 | -mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion
|
|
1369 | +mkGReflLeftCo :: Role -> Type -> KindCoercion -> Coercion
|
|
1332 | 1370 | mkGReflLeftCo r ty co
|
1333 | - | isGReflCo co = mkReflCo r ty
|
|
1334 | - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
|
|
1335 | - -- instead of @isReflCo@
|
|
1336 | - | otherwise = mkSymCo $ mkGReflMCo r ty co
|
|
1371 | + | isReflKindCo co = mkReflCo r ty
|
|
1372 | + | otherwise = mkSymCo $ mkGReflMCo r ty co
|
|
1337 | 1373 | |
1338 | 1374 | -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,
|
1339 | 1375 | -- produces @co' :: (ty |> co) ~r ty'
|
1340 | 1376 | -- It is not only a utility function, but it saves allocation when co
|
1341 | 1377 | -- is a GRefl coercion.
|
1342 | -mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
|
|
1378 | +mkCoherenceLeftCo :: Role -> Type -> KindCoercion -> Coercion -> Coercion
|
|
1343 | 1379 | mkCoherenceLeftCo r ty co co2
|
1344 | - | isGReflCo co = co2
|
|
1345 | - | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2
|
|
1380 | + | isReflKindCo co = co2
|
|
1381 | + | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2
|
|
1346 | 1382 | |
1347 | 1383 | -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
|
1348 | 1384 | -- produces @co' :: ty' ~r (ty |> co)
|
1349 | 1385 | -- It is not only a utility function, but it saves allocation when co
|
1350 | 1386 | -- is a GRefl coercion.
|
1351 | -mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion
|
|
1387 | +mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> KindCoercion -> Coercion -> Coercion
|
|
1352 | 1388 | mkCoherenceRightCo r ty co co2
|
1353 | - | isGReflCo co = co2
|
|
1354 | - | otherwise = co2 `mkTransCo` mkGReflMCo r ty co
|
|
1389 | + | isReflKindCo co = co2
|
|
1390 | + | otherwise = co2 `mkTransCo` mkGReflMCo r ty co
|
|
1355 | 1391 | |
1356 | 1392 | -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
|
1357 | 1393 | mkKindCo :: Coercion -> Coercion
|
... | ... | @@ -1411,18 +1447,19 @@ downgradeRole r1 r2 co |
1411 | 1447 | Nothing -> pprPanic "downgradeRole" (ppr co)
|
1412 | 1448 | |
1413 | 1449 | -- | Make a "coercion between coercions".
|
1414 | -mkProofIrrelCo :: Role -- ^ role of the created coercion, "r"
|
|
1415 | - -> CoercionN -- ^ :: phi1 ~N phi2
|
|
1416 | - -> Coercion -- ^ g1 :: phi1
|
|
1417 | - -> Coercion -- ^ g2 :: phi2
|
|
1418 | - -> Coercion -- ^ :: g1 ~r g2
|
|
1450 | +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r"
|
|
1451 | + -> KindCoercion -- ^ :: phi1 ~N phi2
|
|
1452 | + -> Coercion -- ^ g1 :: phi1
|
|
1453 | + -> Coercion -- ^ g2 :: phi2
|
|
1454 | + -> Coercion -- ^ :: g1 ~r g2
|
|
1419 | 1455 | |
1420 | 1456 | -- if the two coercion prove the same fact, I just don't care what
|
1421 | 1457 | -- the individual coercions are.
|
1422 | -mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g)
|
|
1423 | - -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@
|
|
1424 | -mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r
|
|
1425 | - (mkCoercionTy g1) (mkCoercionTy g2)
|
|
1458 | +mkProofIrrelCo r kco g1 g2
|
|
1459 | + | isReflKindCo kco = mkReflCo r (mkCoercionTy g1)
|
|
1460 | + -- kco is a kind coercion, thus @isReflKindCo@ rather than @isReflCo@
|
|
1461 | + | otherwise = mkUnivCo ProofIrrelProv [kco] r
|
|
1462 | + (mkCoercionTy g1) (mkCoercionTy g2)
|
|
1426 | 1463 | |
1427 | 1464 | {-
|
1428 | 1465 | %************************************************************************
|
... | ... | @@ -2165,16 +2202,17 @@ ty_co_subst !lc role ty |
2165 | 2202 | go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)
|
2166 | 2203 | go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)
|
2167 | 2204 | go r t@(ForAllTy (Bndr v vis) ty)
|
2168 | - = let (lc', v', h) = liftCoSubstVarBndr lc v
|
|
2169 | - body_co = ty_co_subst lc' r ty in
|
|
2170 | - if isTyVar v' || almostDevoidCoVarOfCo v' body_co
|
|
2205 | + = let (lc', v', k_co) = liftCoSubstVarBndr lc v
|
|
2206 | + body_co = ty_co_subst lc' r ty
|
|
2207 | + k_mco = kindCoToMKindCo k_co
|
|
2208 | + in if isTyVar v' || almostDevoidCoVarOfCo v' body_co
|
|
2171 | 2209 | -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo
|
2172 | 2210 | -- imposes an extra restriction on where a covar can appear. See
|
2173 | 2211 | -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep
|
2174 | 2212 | -- We specifically check for this and panic because we know that
|
2175 | 2213 | -- there's a hole in the type system here (see (FC6), and we'd rather
|
2176 | 2214 | -- panic than fall into it.
|
2177 | - then mkForAllCo v' vis vis h body_co
|
|
2215 | + then mkForAllCo v' vis vis k_mco body_co
|
|
2178 | 2216 | else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)
|
2179 | 2217 | go r ty@(LitTy {}) = assert (r == Nominal) $
|
2180 | 2218 | mkNomReflCo ty
|
... | ... | @@ -2262,6 +2300,7 @@ liftCoSubstVarBndr :: LiftingContext -> TyCoVar |
2262 | 2300 | liftCoSubstVarBndr lc tv
|
2263 | 2301 | = liftCoSubstVarBndrUsing id callback lc tv
|
2264 | 2302 | where
|
2303 | + callback :: LiftingContext -> Type -> Coercion
|
|
2265 | 2304 | callback lc' ty' = ty_co_subst lc' Nominal ty'
|
2266 | 2305 | |
2267 | 2306 | -- the callback must produce a nominal coercion
|
... | ... | @@ -2424,7 +2463,7 @@ seqCo (SubCo co) = seqCo co |
2424 | 2463 | seqCo (AxiomCo _ cs) = seqCos cs
|
2425 | 2464 | seqCo (ForAllCo tv visL visR k co)
|
2426 | 2465 | = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq`
|
2427 | - seqCo k `seq` seqCo co
|
|
2466 | + seqMCo k `seq` seqCo co
|
|
2428 | 2467 | seqCo (FunCo r af1 af2 w co1 co2)
|
2429 | 2468 | = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2
|
2430 | 2469 | seqCo (UnivCo { uco_prov = p, uco_role = r
|
... | ... | @@ -2522,7 +2561,7 @@ coercion_lr_kind which orig_co |
2522 | 2561 | , fco_kind = k_co, fco_body = co1 })
|
2523 | 2562 | = case which of
|
2524 | 2563 | CLeft -> mkTyCoForAllTy tv1 visL (go co1)
|
2525 | - CRight | isGReflCo k_co -- kind_co always has kind `Type`, thus `isGReflCo`
|
|
2564 | + CRight | isReflKindMCo k_co
|
|
2526 | 2565 | -> mkTyCoForAllTy tv1 visR (go co1)
|
2527 | 2566 | | otherwise
|
2528 | 2567 | -> go_forall_right empty_subst co
|
... | ... | @@ -2577,43 +2616,47 @@ coercion_lr_kind which orig_co |
2577 | 2616 | |
2578 | 2617 | -------------
|
2579 | 2618 | go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR
|
2580 | - , fco_kind = k_co, fco_body = co })
|
|
2619 | + , fco_kind = k_mco, fco_body = co })
|
|
2581 | 2620 | -- See Note [Nested ForAllCos]
|
2582 | 2621 | | isTyVar tv1
|
2583 | - = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)
|
|
2584 | - where
|
|
2585 | - k2 = coercionRKind k_co
|
|
2586 | - tv2 = setTyVarKind tv1 (substTy subst k2)
|
|
2587 | - subst' | isGReflCo k_co = extendSubstInScope subst tv1
|
|
2588 | - -- kind_co always has kind @Type@, thus @isGReflCo@
|
|
2589 | - | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $
|
|
2590 | - TyVarTy tv2 `mkCastTy` mkSymCo k_co
|
|
2622 | + = case k_mco of
|
|
2623 | + MRefl -> mkForAllTy (Bndr tv1 visR) (go_forall_right subst' co)
|
|
2624 | + where
|
|
2625 | + subst' = extendSubstInScope subst tv1
|
|
2626 | + MCo k_co -> mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)
|
|
2627 | + where
|
|
2628 | + k2 = coercionRKind k_co
|
|
2629 | + tv2 = setTyVarKind tv1 (substTy subst k2)
|
|
2630 | + subst' = extendTvSubst (extendSubstInScope subst tv2) tv1 $
|
|
2631 | + TyVarTy tv2 `mkCastTy` mkSymCo k_co
|
|
2591 | 2632 | |
2592 | 2633 | go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR
|
2593 | - , fco_kind = k_co, fco_body = co })
|
|
2634 | + , fco_kind = k_mco, fco_body = co })
|
|
2594 | 2635 | | isCoVar cv1
|
2595 | - = mkTyCoForAllTy cv2 visR (go_forall_right subst' co)
|
|
2596 | - where
|
|
2597 | - k2 = coercionRKind k_co
|
|
2598 | - r = coVarRole cv1
|
|
2599 | - k_co' = downgradeRole r Nominal k_co
|
|
2600 | - eta1 = mkSelCo (SelTyCon 2 r) k_co'
|
|
2601 | - eta2 = mkSelCo (SelTyCon 3 r) k_co'
|
|
2602 | - |
|
2603 | - -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
|
|
2604 | - -- k1 = t1 ~r t2
|
|
2605 | - -- k2 = s1 ~r s2
|
|
2606 | - -- cv1 :: t1 ~r t2
|
|
2607 | - -- cv2 :: s1 ~r s2
|
|
2608 | - -- eta1 :: t1 ~r s1
|
|
2609 | - -- eta2 :: t2 ~r s2
|
|
2610 | - -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2
|
|
2611 | - |
|
2612 | - cv2 = setVarType cv1 (substTy subst k2)
|
|
2613 | - n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)
|
|
2614 | - subst' | isReflCo k_co = extendSubstInScope subst cv1
|
|
2615 | - | otherwise = extendCvSubst (extendSubstInScope subst cv2)
|
|
2616 | - cv1 n_subst
|
|
2636 | + = case k_mco of
|
|
2637 | + MRefl -> mkTyCoForAllTy cv1 visR (go_forall_right subst' co)
|
|
2638 | + where
|
|
2639 | + subst' = extendSubstInScope subst cv1
|
|
2640 | + MCo k_co -> mkTyCoForAllTy cv2 visR (go_forall_right subst' co)
|
|
2641 | + where
|
|
2642 | + k2 = coercionRKind k_co
|
|
2643 | + r = coVarRole cv1
|
|
2644 | + k_co' = downgradeRole r Nominal k_co
|
|
2645 | + eta1 = mkSelCo (SelTyCon 2 r) k_co'
|
|
2646 | + eta2 = mkSelCo (SelTyCon 3 r) k_co'
|
|
2647 | + |
|
2648 | + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
|
|
2649 | + -- k1 = t1 ~r t2
|
|
2650 | + -- k2 = s1 ~r s2
|
|
2651 | + -- cv1 :: t1 ~r t2
|
|
2652 | + -- cv2 :: s1 ~r s2
|
|
2653 | + -- eta1 :: t1 ~r s1
|
|
2654 | + -- eta2 :: t2 ~r s2
|
|
2655 | + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2
|
|
2656 | + |
|
2657 | + cv2 = setVarType cv1 (substTy subst k2)
|
|
2658 | + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)
|
|
2659 | + subst' = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst
|
|
2617 | 2660 | |
2618 | 2661 | go_forall_right subst other_co
|
2619 | 2662 | -- when other_co is not a ForAllCo
|
... | ... | @@ -2729,7 +2772,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 |
2729 | 2772 | go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)
|
2730 | 2773 | | isTyVar tv1
|
2731 | 2774 | = assert (isTyVar tv2) $
|
2732 | - mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')
|
|
2775 | + mkForAllCo tv1 flag1 flag2 (kindCoToMKindCo kind_co) (go ty1 ty2')
|
|
2733 | 2776 | where kind_co = go (tyVarKind tv1) (tyVarKind tv2)
|
2734 | 2777 | in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
|
2735 | 2778 | ty2' = substTyWithInScope in_scope [tv2]
|
... | ... | @@ -2738,7 +2781,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 |
2738 | 2781 | |
2739 | 2782 | go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)
|
2740 | 2783 | = assert (isCoVar cv1 && isCoVar cv2) $
|
2741 | - mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')
|
|
2784 | + mkForAllCo cv1 flag1 flag2 (kindCoToMKindCo kind_co) (go ty1 ty2')
|
|
2742 | 2785 | where s1 = varType cv1
|
2743 | 2786 | s2 = varType cv2
|
2744 | 2787 | kind_co = go s1 s2
|
... | ... | @@ -2755,7 +2798,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 |
2755 | 2798 | eta2 = mkSelCo (SelTyCon 3 r) kind_co'
|
2756 | 2799 | |
2757 | 2800 | subst = mkEmptySubst $ mkInScopeSet $
|
2758 | - tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
|
|
2801 | + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
|
|
2759 | 2802 | ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`
|
2760 | 2803 | mkCoVarCo cv1 `mkTransCo`
|
2761 | 2804 | eta2)
|
... | ... | @@ -16,7 +16,7 @@ import GHC.Utils.Misc |
16 | 16 | mkReflCo :: Role -> Type -> Coercion
|
17 | 17 | mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
|
18 | 18 | mkAppCo :: Coercion -> Coercion -> Coercion
|
19 | -mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion
|
|
19 | +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> MCoercion -> Coercion -> Coercion
|
|
20 | 20 | mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
|
21 | 21 | mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
|
22 | 22 | mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
|
... | ... | @@ -37,7 +37,6 @@ mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion |
37 | 37 | |
38 | 38 | funRole :: Role -> FunSel -> Role
|
39 | 39 | |
40 | -isGReflCo :: Coercion -> Bool
|
|
41 | 40 | isReflCo :: Coercion -> Bool
|
42 | 41 | isReflexiveCo :: Coercion -> Bool
|
43 | 42 | decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
|
... | ... | @@ -177,12 +177,12 @@ optCoercion opts env co |
177 | 177 | = optCoercion' env co
|
178 | 178 | |
179 | 179 | {-
|
180 | - = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $
|
|
180 | + = pprTrace "optCoercion {" (text "Co:" <> ppr co) $
|
|
181 | 181 | let result = optCoercion' env co in
|
182 | 182 | pprTrace "optCoercion }"
|
183 | 183 | (vcat [ text "Co:" <+> ppr (coercionSize co)
|
184 | 184 | , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)")
|
185 | - <+> ppr (coercionSize result) ]) $
|
|
185 | + <+> ppr result ]) $
|
|
186 | 186 | result
|
187 | 187 | -}
|
188 | 188 | |
... | ... | @@ -317,7 +317,7 @@ opt_co4' env sym rep r (GRefl _r ty (MCo kco)) |
317 | 317 | (text "Expected role:" <+> ppr r $$
|
318 | 318 | text "Found role:" <+> ppr _r $$
|
319 | 319 | text "Type:" <+> ppr ty) $
|
320 | - if isGReflCo kco || isGReflCo kco'
|
|
320 | + if isReflKindCo kco || isReflKindCo kco'
|
|
321 | 321 | then wrapSym sym ty_co
|
322 | 322 | else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co
|
323 | 323 | -- ty :: k1
|
... | ... | @@ -841,55 +841,58 @@ opt_trans_rule is co1 co2@(AppCo co2a co2b) |
841 | 841 | -- Push transitivity inside forall
|
842 | 842 | -- forall over types.
|
843 | 843 | opt_trans_rule is co1 co2
|
844 | - | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1
|
|
845 | - , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2
|
|
846 | - = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2
|
|
844 | + | Just (tv1, visL1, _visR1, kco1, r1) <- splitForAllCo_ty_maybe co1
|
|
845 | + , Just (tv2, _visL2, visR2, kco2, r2) <- etaForAllCo_ty_maybe co2
|
|
846 | + = push_trans tv1 kco1 r1 tv2 kco2 r2 visL1 visR2
|
|
847 | 847 | |
848 | - | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2
|
|
849 | - , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1
|
|
850 | - = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2
|
|
848 | + | Just (tv2, _visL2, visR2, kco2, r2) <- splitForAllCo_ty_maybe co2
|
|
849 | + , Just (tv1, visL1, _visR1, kco1, r1) <- etaForAllCo_ty_maybe co1
|
|
850 | + = push_trans tv1 kco1 r1 tv2 kco2 r2 visL1 visR2
|
|
851 | 851 | |
852 | 852 | where
|
853 | - push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR
|
|
853 | + push_trans tv1 kco1 r1 tv2 kco2 r2 visL visR
|
|
854 | 854 | -- Given:
|
855 | - -- co1 = /\ tv1 : eta1 <visL, visM>. r1
|
|
856 | - -- co2 = /\ tv2 : eta2 <visM, visR>. r2
|
|
855 | + -- co1 = /\ tv1 : kco1 <visL, visM>. r1
|
|
856 | + -- co2 = /\ tv2 : kco2 <visM, visR>. r2
|
|
857 | 857 | -- Wanted:
|
858 | - -- /\tv1 : (eta1;eta2) <visL, visR>. (r1; r2[tv2 |-> tv1 |> eta1])
|
|
858 | + -- /\tv1 : (kco1;kco2) <visL, visR>. (r1; r2[tv2 |-> tv1 |> kco1])
|
|
859 | 859 | = fireTransRule "EtaAllTy_ty" co1 co2 $
|
860 | - mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
|
|
860 | + mkForAllCo tv1 visL visR
|
|
861 | + (kindCoToMKindCo (opt_trans is kco1 kco2))
|
|
862 | + (opt_trans is' r1 r2')
|
|
861 | 863 | where
|
862 | 864 | is' = is `extendInScopeSet` tv1
|
863 | - r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2
|
|
865 | + r2' = substCoWithInScope is' [tv2] [mkCastTy (TyVarTy tv1) kco1] r2
|
|
864 | 866 | |
865 | 867 | -- Push transitivity inside forall
|
866 | 868 | -- forall over coercions.
|
867 | 869 | opt_trans_rule is co1 co2
|
868 | - | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1
|
|
869 | - , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2
|
|
870 | - = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2
|
|
870 | + | Just (cv1, visL1, _visR1, kco1, r1) <- splitForAllCo_co_maybe co1
|
|
871 | + , Just (cv2, _visL2, visR2, kco2, r2) <- etaForAllCo_co_maybe co2
|
|
872 | + = push_trans cv1 kco1 r1 cv2 kco2 r2 visL1 visR2
|
|
871 | 873 | |
872 | - | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2
|
|
873 | - , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1
|
|
874 | - = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2
|
|
874 | + | Just (cv2, _visL2, visR2, kco2, r2) <- splitForAllCo_co_maybe co2
|
|
875 | + , Just (cv1, visL1, _visR1, kco1, r1) <- etaForAllCo_co_maybe co1
|
|
876 | + = push_trans cv1 kco1 r1 cv2 kco2 r2 visL1 visR2
|
|
875 | 877 | |
876 | 878 | where
|
877 | - push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR
|
|
879 | + push_trans cv1 kco1 r1 cv2 kco2 r2 visL visR
|
|
878 | 880 | -- Given:
|
879 | - -- co1 = /\ (cv1 : eta1) <visL, visM>. r1
|
|
880 | - -- co2 = /\ (cv2 : eta2) <visM, visR>. r2
|
|
881 | + -- co1 = /\ (cv1 : kco1) <visL, visM>. r1
|
|
882 | + -- co2 = /\ (cv2 : kco2) <visM, visR>. r2
|
|
881 | 883 | -- Wanted:
|
882 | - -- n1 = nth 2 eta1
|
|
883 | - -- n2 = nth 3 eta1
|
|
884 | - -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])
|
|
884 | + -- n1 = nth 2 kco1
|
|
885 | + -- n2 = nth 3 kco1
|
|
886 | + -- nco = /\ cv1 : (kco1;kco2). (r1; r2[cv2 |-> (sym n1);cv1;n2])
|
|
885 | 887 | = fireTransRule "EtaAllTy_co" co1 co2 $
|
886 | - mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
|
|
888 | + mkForAllCo cv1 visL visR (coToMCo (opt_trans is kco1 kco2))
|
|
889 | + (opt_trans is' r1 r2')
|
|
887 | 890 | where
|
888 | 891 | is' = is `extendInScopeSet` cv1
|
889 | 892 | role = coVarRole cv1
|
890 | - eta1' = downgradeRole role Nominal eta1
|
|
891 | - n1 = mkSelCo (SelTyCon 2 role) eta1'
|
|
892 | - n2 = mkSelCo (SelTyCon 3 role) eta1'
|
|
893 | + kco1' = downgradeRole role Nominal kco1
|
|
894 | + n1 = mkSelCo (SelTyCon 2 role) kco1'
|
|
895 | + n2 = mkSelCo (SelTyCon 3 role) kco1'
|
|
893 | 896 | r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co`
|
894 | 897 | (mkCoVarCo cv1) `mk_trans_co` n2])
|
895 | 898 | r2
|
... | ... | @@ -1285,7 +1288,8 @@ Here, |
1285 | 1288 | eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)
|
1286 | 1289 | h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))
|
1287 | 1290 | -}
|
1288 | -etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
|
|
1291 | +etaForAllCo_ty_maybe :: Coercion
|
|
1292 | + -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
|
|
1289 | 1293 | -- Try to make the coercion be of form (forall tv:kind_co. co)
|
1290 | 1294 | etaForAllCo_ty_maybe co
|
1291 | 1295 | | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co
|
... | ... | @@ -1305,7 +1309,8 @@ etaForAllCo_ty_maybe co |
1305 | 1309 | | otherwise
|
1306 | 1310 | = Nothing
|
1307 | 1311 | |
1308 | -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
|
|
1312 | +etaForAllCo_co_maybe :: Coercion
|
|
1313 | + -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
|
|
1309 | 1314 | -- Try to make the coercion be of form (forall cv:kind_co. co)
|
1310 | 1315 | etaForAllCo_co_maybe co
|
1311 | 1316 | | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co
|
... | ... | @@ -1428,13 +1433,17 @@ But if sym=Swapped, things are trickier. Here is an identity that helps: |
1428 | 1433 | |
1429 | 1434 | -}
|
1430 | 1435 | optForAllCoBndr :: LiftingContext -> SwapFlag
|
1431 | - -> TyCoVar -> Coercion
|
|
1432 | - -> (LiftingContext, TyCoVar, Coercion)
|
|
1436 | + -> TyCoVar -> MCoercionN
|
|
1437 | + -> (LiftingContext, TyCoVar, MCoercionN)
|
|
1433 | 1438 | -- See Note [Optimising ForAllCo]
|
1434 | -optForAllCoBndr env sym tcv kco
|
|
1435 | - = (env', tcv', kco')
|
|
1439 | +optForAllCoBndr env sym tcv k_mco
|
|
1440 | + = (env', tcv', k_mco')
|
|
1436 | 1441 | where
|
1437 | - kco' = opt_co4 env sym False Nominal kco -- Push sym into kco
|
|
1442 | + -- Push sym into kco
|
|
1443 | + k_mco' = case k_mco of
|
|
1444 | + MRefl -> MRefl
|
|
1445 | + MCo co -> MCo (opt_co4 env sym False Nominal co)
|
|
1446 | + |
|
1438 | 1447 | (env', tcv') = updateLCSubst env upd_subst
|
1439 | 1448 | |
1440 | 1449 | upd_subst :: Subst -> (Subst, TyCoVar)
|
... | ... | @@ -1443,26 +1452,32 @@ optForAllCoBndr env sym tcv kco |
1443 | 1452 | | otherwise = upd_subst_cv subst
|
1444 | 1453 | |
1445 | 1454 | upd_subst_tv subst
|
1446 | - | notSwapped sym || isReflCo kco' = (subst1, tv1)
|
|
1447 | - | otherwise = (subst2, tv2)
|
|
1455 | + = case k_mco' of
|
|
1456 | + MCo k_co' | isSwapped sym -> (subst2, tv2)
|
|
1457 | + where
|
|
1458 | + -- In the Swapped case, we re-kind the type variable, AND
|
|
1459 | + -- override the substitution for the original variable to the
|
|
1460 | + -- re-kinded one, suitably casted
|
|
1461 | + tv2 = tv1 `setTyVarKind` coercionLKind k_co'
|
|
1462 | + subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` k_co'))
|
|
1463 | + `extendSubstInScope` tv2
|
|
1464 | + |
|
1465 | + _ -> (subst1, tv1)
|
|
1448 | 1466 | where
|
1449 | 1467 | -- subst1,tv1: apply the substitution to the binder and its kind
|
1450 | 1468 | -- NB: varKind tv = coercionLKind kco
|
1451 | 1469 | (subst1, tv1) = substTyVarBndr subst tcv
|
1452 | - -- In the Swapped case, we re-kind the type variable, AND
|
|
1453 | - -- override the substitution for the original variable to the
|
|
1454 | - -- re-kinded one, suitably casted
|
|
1455 | - tv2 = tv1 `setTyVarKind` coercionLKind kco'
|
|
1456 | - subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))
|
|
1457 | - `extendSubstInScope` tv2
|
|
1458 | 1470 | |
1459 | 1471 | upd_subst_cv subst -- ToDo: probably not right yet
|
1460 | - | notSwapped sym || isReflCo kco' = (subst1, cv1)
|
|
1461 | - | otherwise = (subst2, cv2)
|
|
1462 | - where
|
|
1472 | + = case k_mco' of
|
|
1473 | + MCo k_co' | isSwapped sym -> (subst2, cv2)
|
|
1474 | + where
|
|
1475 | + cv2 = cv1 `setTyVarKind` coercionLKind k_co'
|
|
1476 | + subst2 = subst1 `extendSubstInScope` cv2
|
|
1477 | + |
|
1478 | + _ -> (subst1, cv1)
|
|
1479 | + where
|
|
1463 | 1480 | (subst1, cv1) = substCoVarBndr subst tcv
|
1464 | - cv2 = cv1 `setTyVarKind` coercionLKind kco'
|
|
1465 | - subst2 = subst1 `extendSubstInScope` cv2
|
|
1466 | 1481 | |
1467 | 1482 | |
1468 | 1483 | {- **********************************************************************
|
... | ... | @@ -2424,15 +2424,19 @@ lintCoercion co@(ForAllCo {}) |
2424 | 2424 | go :: [OutTyCoVar] -- Binders in reverse order
|
2425 | 2425 | -> InCoercion -> LintM Role
|
2426 | 2426 | go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
|
2427 | - , fco_kind = kind_co, fco_body = body_co })
|
|
2427 | + , fco_kind = kind_mco, fco_body = body_co })
|
|
2428 | 2428 | | not (isTyCoVar tcv)
|
2429 | 2429 | = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)
|
2430 | 2430 | |
2431 | 2431 | | otherwise
|
2432 | - = do { lk <- lintStarCoercion kind_co
|
|
2432 | + = do { mb_lk <- case kind_mco of
|
|
2433 | + MRefl -> return Nothing
|
|
2434 | + MCo kind_co -> Just <$> lintStarCoercion kind_co
|
|
2433 | 2435 | ; lintTyCoBndr tcv $ \tcv' ->
|
2434 | - do { ensureEqTys (varType tcv') lk $
|
|
2435 | - text "Kind mis-match in ForallCo" <+> ppr co
|
|
2436 | + do { case mb_lk of
|
|
2437 | + Nothing -> return ()
|
|
2438 | + Just lk -> ensureEqTys (varType tcv') lk $
|
|
2439 | + text "Kind mis-match in ForallCo" <+> ppr co
|
|
2436 | 2440 | |
2437 | 2441 | -- I'm not very sure about this part, because it traverses body_co
|
2438 | 2442 | -- but at least it's on a cold path (a ForallCo for a CoVar)
|
... | ... | @@ -2367,8 +2367,7 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco |
2367 | 2367 | | otherwise -> mk_fco (mkRepReflCo ty)
|
2368 | 2368 | MCo co -> mk_fco co
|
2369 | 2369 | where
|
2370 | - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag
|
|
2371 | - (mkNomReflCo (varType tcv)) co)
|
|
2370 | + mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co)
|
|
2372 | 2371 | -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly
|
2373 | 2372 | -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has
|
2374 | 2373 | -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]
|
... | ... | @@ -2808,11 +2807,10 @@ tryEtaReduce rec_ids bndrs body eval_sd |
2808 | 2807 | | Just tv <- getTyVar_maybe arg_ty
|
2809 | 2808 | , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of
|
2810 | 2809 | Just (Bndr _ vis, _) -> Just (fco, [])
|
2811 | - where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co
|
|
2810 | + where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag MRefl co
|
|
2812 | 2811 | -- The lambda we are eta-reducing always has visibility
|
2813 | 2812 | -- 'coreTyLamForAllTyFlag' which may or may not match
|
2814 | 2813 | -- the visibility on the inner function (#24014)
|
2815 | - kco = mkNomReflCo (tyVarKind tv)
|
|
2816 | 2814 | Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"
|
2817 | 2815 | (text "fun:" <+> ppr bndr
|
2818 | 2816 | $$ text "arg:" <+> ppr arg_ty
|
... | ... | @@ -373,7 +373,7 @@ mkForAllRedn :: ForAllTyFlag |
373 | 373 | -> Reduction
|
374 | 374 | mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)
|
375 | 375 | = mkReduction
|
376 | - (mkForAllCo tv1 vis vis h co)
|
|
376 | + (mkForAllCo tv1 vis vis (kindCoToMKindCo h) co)
|
|
377 | 377 | (mkForAllTy (Bndr tv2 vis) ty)
|
378 | 378 | where
|
379 | 379 | tv2 = setTyVarKind tv1 ki'
|
... | ... | @@ -51,7 +51,6 @@ module GHC.Core.TyCo.FVs |
51 | 51 | import GHC.Prelude
|
52 | 52 | |
53 | 53 | import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView )
|
54 | -import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind )
|
|
55 | 54 | |
56 | 55 | import GHC.Builtin.Types.Prim( funTyFlagTyCon )
|
57 | 56 | |
... | ... | @@ -641,8 +640,10 @@ tyCoVarsOfCoList :: Coercion -> [TyCoVar] |
641 | 640 | tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co
|
642 | 641 | |
643 | 642 | tyCoFVsOfMCo :: MCoercion -> FV
|
644 | -tyCoFVsOfMCo MRefl = emptyFV
|
|
645 | -tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co
|
|
643 | +tyCoFVsOfMCo mco fv_cand in_scope acc
|
|
644 | + = case mco of
|
|
645 | + MRefl -> emptyFV fv_cand in_scope acc
|
|
646 | + MCo co -> tyCoFVsOfCo co fv_cand in_scope acc
|
|
646 | 647 | |
647 | 648 | tyCoFVsOfCo :: Coercion -> FV
|
648 | 649 | -- Extracts type and coercion variables from a coercion
|
... | ... | @@ -655,7 +656,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand |
655 | 656 | tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc
|
656 | 657 | = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc
|
657 | 658 | tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc
|
658 | - = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc
|
|
659 | + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfMCo kind_co) fv_cand in_scope acc
|
|
659 | 660 | tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc
|
660 | 661 | = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc
|
661 | 662 | tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc
|
... | ... | @@ -693,6 +694,10 @@ almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool |
693 | 694 | almostDevoidCoVarOfCo cv co =
|
694 | 695 | almost_devoid_co_var_of_co co cv
|
695 | 696 | |
697 | +almost_devoid_co_var_of_mco :: MCoercion -> CoVar -> Bool
|
|
698 | +almost_devoid_co_var_of_mco MRefl _ = True
|
|
699 | +almost_devoid_co_var_of_mco (MCo co) cv = almost_devoid_co_var_of_co co cv
|
|
700 | + |
|
696 | 701 | almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool
|
697 | 702 | almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and
|
698 | 703 | almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into
|
... | ... | @@ -703,7 +708,7 @@ almost_devoid_co_var_of_co (AppCo co arg) cv |
703 | 708 | = almost_devoid_co_var_of_co co cv
|
704 | 709 | && almost_devoid_co_var_of_co arg cv
|
705 | 710 | almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv
|
706 | - = almost_devoid_co_var_of_co kind_co cv
|
|
711 | + = almost_devoid_co_var_of_mco kind_co cv
|
|
707 | 712 | && (v == cv || almost_devoid_co_var_of_co co cv)
|
708 | 713 | almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv
|
709 | 714 | = almost_devoid_co_var_of_co w cv
|
... | ... | @@ -1032,7 +1037,7 @@ tyConsOfType ty |
1032 | 1037 | go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args
|
1033 | 1038 | go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg
|
1034 | 1039 | go_co (ForAllCo { fco_kind = kind_co, fco_body = co })
|
1035 | - = go_co kind_co `unionUniqSets` go_co co
|
|
1040 | + = go_mco kind_co `unionUniqSets` go_co co
|
|
1036 | 1041 | go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
|
1037 | 1042 | = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r
|
1038 | 1043 | go_co (AxiomCo ax args) = go_ax ax `unionUniqSets` go_cos args
|
... | ... | @@ -1230,14 +1235,14 @@ occCheckExpand vs_to_avoid ty |
1230 | 1235 | go_co cxt (SubCo co) = do { co' <- go_co cxt co
|
1231 | 1236 | ; return (SubCo co') }
|
1232 | 1237 | |
1233 | - go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })
|
|
1234 | - = do { kind_co' <- go_co cxt kind_co
|
|
1235 | - ; let tv' = setVarType tv $
|
|
1236 | - coercionLKind kind_co'
|
|
1237 | - env' = extendVarEnv env tv tv'
|
|
1238 | - as' = as `delVarSet` tv
|
|
1238 | + go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = body_co })
|
|
1239 | + = do { ki' <- go cxt (varType tcv)
|
|
1240 | + ; let tcv' = setVarType tcv ki'
|
|
1241 | + env' = extendVarEnv env tcv tcv'
|
|
1242 | + as' = as `delVarSet` tcv
|
|
1243 | + ; kind_co' <- go_mco cxt kind_co
|
|
1239 | 1244 | ; body' <- go_co (as', env') body_co
|
1240 | - ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }
|
|
1245 | + ; return (co { fco_tcv = tcv', fco_kind = kind_co', fco_body = body' }) }
|
|
1241 | 1246 | |
1242 | 1247 | go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })
|
1243 | 1248 | = do { co1' <- go_co cxt co1
|
... | ... | @@ -39,7 +39,7 @@ module GHC.Core.TyCo.Rep ( |
39 | 39 | UnivCoProvenance(..),
|
40 | 40 | CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
|
41 | 41 | CoercionN, CoercionR, CoercionP, KindCoercion,
|
42 | - MCoercion(..), MCoercionR, MCoercionN,
|
|
42 | + MCoercion(..), MCoercionR, MCoercionN, KindMCoercion,
|
|
43 | 43 | |
44 | 44 | -- * Functions over types
|
45 | 45 | mkNakedTyConTy, mkTyVarTy, mkTyVarTys,
|
... | ... | @@ -806,6 +806,34 @@ tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res |
806 | 806 | %************************************************************************
|
807 | 807 | -}
|
808 | 808 | |
809 | +type CoercionN = Coercion -- always Nominal
|
|
810 | +type CoercionR = Coercion -- always Representational
|
|
811 | +type CoercionP = Coercion -- always Phantom
|
|
812 | + |
|
813 | +type MCoercionN = MCoercion -- alwyas Nominal
|
|
814 | +type MCoercionR = MCoercion -- always Representational
|
|
815 | + |
|
816 | +{- Note [KindCoercion]
|
|
817 | +~~~~~~~~~~~~~~~~~~~~~~
|
|
818 | +A KindCoercion kco :: k1 ~r k2 is a Coercion with these properties:
|
|
819 | + (a) It is Nominal; that is r=Nominal
|
|
820 | + (b) Both (k1::Type) and (k2::Type); it is homogeneous
|
|
821 | + |
|
822 | +The coercion in (a) ForAllCo and (b) CastTy is a KindCoercion.
|
|
823 | + |
|
824 | +The invariants of KindCoercion allow `isReflKindCo` to elminate GRefl,
|
|
825 | +whereas isReflCo cannot. In particular, consider a KindCoercion
|
|
826 | + kco = GRefl r k (MCo kk)) :: k ~ (k |> kk)
|
|
827 | +Since `kco`is a KindCoercion, we know that
|
|
828 | + r = Nominal
|
|
829 | + k :: Type and (k |> kk) :: Type
|
|
830 | +Hence kk must be Refl. And hence kco = GRefl N k MRefl, which is
|
|
831 | +the same as Refl. See `isReflKindCo`.
|
|
832 | +-}
|
|
833 | + |
|
834 | +type KindCoercion = CoercionN -- See Note [KindCoercion]
|
|
835 | +type KindMCoercion = MCoercionN -- See Note [KindCoercion]
|
|
836 | + |
|
809 | 837 | -- | A 'Coercion' is concrete evidence of the equality/convertibility
|
810 | 838 | -- of two types.
|
811 | 839 | |
... | ... | @@ -829,7 +857,7 @@ data Coercion |
829 | 857 | |
830 | 858 | -- GRefl :: "e" -> _ -> Maybe N -> e
|
831 | 859 | -- See Note [Generalized reflexive coercion]
|
832 | - | GRefl Role Type MCoercionN -- See Note [Refl invariant]
|
|
860 | + | GRefl Role Type KindMCoercion -- See Note [Refl invariant]
|
|
833 | 861 | -- Use (Refl ty), not (GRefl Nominal ty MRefl)
|
834 | 862 | -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))
|
835 | 863 | |
... | ... | @@ -853,7 +881,7 @@ data Coercion |
853 | 881 | , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind
|
854 | 882 | , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind
|
855 | 883 | -- See (FC7) of Note [ForAllCo]
|
856 | - , fco_kind :: KindCoercion
|
|
884 | + , fco_kind :: KindMCoercion -- See (FC8) of Note [ForAllCo]
|
|
857 | 885 | , fco_body :: Coercion }
|
858 | 886 | -- ForAllCo :: _ -> N -> e -> e
|
859 | 887 | |
... | ... | @@ -911,6 +939,15 @@ data Coercion |
911 | 939 | -- Only present during typechecking
|
912 | 940 | deriving Data.Data
|
913 | 941 | |
942 | +-- | A semantically more meaningful type to represent what may or may not be a
|
|
943 | +-- useful 'Coercion'.
|
|
944 | +data MCoercion
|
|
945 | + = MRefl
|
|
946 | + -- A trivial Reflexivity coercion
|
|
947 | + | MCo Coercion
|
|
948 | + -- Other coercions
|
|
949 | + deriving Data.Data
|
|
950 | + |
|
914 | 951 | data CoSel -- See Note [SelCo]
|
915 | 952 | = SelTyCon Int Role -- Decomposes (T co1 ... con); zero-indexed
|
916 | 953 | -- Invariant: Given: SelCo (SelTyCon i r) co
|
... | ... | @@ -932,11 +969,6 @@ data FunSel -- See Note [SelCo] |
932 | 969 | | SelRes -- Result of function
|
933 | 970 | deriving( Eq, Data.Data, Ord )
|
934 | 971 | |
935 | -type CoercionN = Coercion -- always nominal
|
|
936 | -type CoercionR = Coercion -- always representational
|
|
937 | -type CoercionP = Coercion -- always phantom
|
|
938 | -type KindCoercion = CoercionN -- always nominal
|
|
939 | - |
|
940 | 972 | instance Outputable Coercion where
|
941 | 973 | ppr = pprCo
|
942 | 974 | |
... | ... | @@ -980,17 +1012,6 @@ instance NFData CoSel where |
980 | 1012 | rnf SelForAll = ()
|
981 | 1013 | rnf (SelFun fs) = rnf fs `seq` ()
|
982 | 1014 | |
983 | --- | A semantically more meaningful type to represent what may or may not be a
|
|
984 | --- useful 'Coercion'.
|
|
985 | -data MCoercion
|
|
986 | - = MRefl
|
|
987 | - -- A trivial Reflexivity coercion
|
|
988 | - | MCo Coercion
|
|
989 | - -- Other coercions
|
|
990 | - deriving Data.Data
|
|
991 | -type MCoercionR = MCoercion
|
|
992 | -type MCoercionN = MCoercion
|
|
993 | - |
|
994 | 1015 | instance Outputable MCoercion where
|
995 | 1016 | ppr MRefl = text "MRefl"
|
996 | 1017 | ppr (MCo co) = text "MCo" <+> ppr co
|
... | ... | @@ -1278,6 +1299,14 @@ Several things to note here |
1278 | 1299 | fco_visL = fco_visR = coreTyLamForAllTyFlag
|
1279 | 1300 | c.f. (FT2) in Note [ForAllTy]
|
1280 | 1301 | |
1302 | +(FC8) We /represent/ a ForAllCo { fco_tcv = tcv, fco_kind = kmco } as follows:
|
|
1303 | + * The tcv::TyCoVar has a kind (like any Var), say tcv::ki
|
|
1304 | + * The kind-coercion `kmco` is a KindMCoercion:
|
|
1305 | + - If kmco = MRefl, then the coercion in the typing rule is (Refl ki)
|
|
1306 | + - If kmco = MCo kco, then the coercion in the typing rule is `co`,
|
|
1307 | + /and/ ki = coercionLKind kco
|
|
1308 | + So in the common MRefl case, the kind of `tcv` plays a useful role.
|
|
1309 | + |
|
1281 | 1310 | Note [Predicate coercions]
|
1282 | 1311 | ~~~~~~~~~~~~~~~~~~~~~~~~~~
|
1283 | 1312 | Suppose we have
|
... | ... | @@ -1937,11 +1966,14 @@ foldTyCo (TyCoFolder { tcf_view = view |
1937 | 1966 | go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })
|
1938 | 1967 | = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2
|
1939 | 1968 | |
1940 | - go_co env (ForAllCo tv _vis1 _vis2 kind_co co)
|
|
1941 | - = go_co env kind_co `mappend` go_ty env (varType tv)
|
|
1942 | - `mappend` go_co env' co
|
|
1969 | + go_co env (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co })
|
|
1970 | + = go_mco env kind_co `mappend` go_ty env (varType tcv)
|
|
1971 | + `mappend` go_co env' co
|
|
1943 | 1972 | where
|
1944 | - env' = tycobinder env tv Inferred
|
|
1973 | + env' = tycobinder env tcv Inferred
|
|
1974 | + |
|
1975 | + go_mco _ MRefl = mempty
|
|
1976 | + go_mco env (MCo co) = go_co env co
|
|
1945 | 1977 | |
1946 | 1978 | -- | A view function that looks through nothing.
|
1947 | 1979 | noView :: Type -> Maybe Type
|
... | ... | @@ -1983,18 +2015,19 @@ typesSize tys = foldr ((+) . typeSize) 0 tys |
1983 | 2015 | |
1984 | 2016 | coercionSize :: Coercion -> Int
|
1985 | 2017 | coercionSize (Refl ty) = typeSize ty
|
1986 | -coercionSize (GRefl _ ty MRefl) = typeSize ty
|
|
1987 | -coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co
|
|
2018 | +coercionSize (GRefl _ ty mco) = typeSize ty + mCoercionSize mco
|
|
1988 | 2019 | coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)
|
1989 | 2020 | coercionSize (AppCo co arg) = coercionSize co + coercionSize arg
|
1990 | 2021 | coercionSize (ForAllCo { fco_kind = h, fco_body = co })
|
1991 | - = 1 + coercionSize co + coercionSize h
|
|
2022 | + = 1 + coercionSize co + mCoercionSize h
|
|
1992 | 2023 | coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2
|
1993 | 2024 | + coercionSize w
|
1994 | 2025 | coercionSize (CoVarCo _) = 1
|
1995 | 2026 | coercionSize (HoleCo _) = 1
|
1996 | 2027 | coercionSize (AxiomCo _ cs) = 1 + sum (map coercionSize cs)
|
1997 | -coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 }) = 1 + typeSize t1 + typeSize t2
|
|
2028 | +coercionSize (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })
|
|
2029 | + = 1 + typeSize t1 + typeSize t2
|
|
2030 | + + sum (map coercionSize deps)
|
|
1998 | 2031 | coercionSize (SymCo co) = 1 + coercionSize co
|
1999 | 2032 | coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
|
2000 | 2033 | coercionSize (SelCo _ co) = 1 + coercionSize co
|
... | ... | @@ -2003,6 +2036,10 @@ coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg |
2003 | 2036 | coercionSize (KindCo co) = 1 + coercionSize co
|
2004 | 2037 | coercionSize (SubCo co) = 1 + coercionSize co
|
2005 | 2038 | |
2039 | +mCoercionSize :: MCoercion -> Int
|
|
2040 | +mCoercionSize MRefl = 0
|
|
2041 | +mCoercionSize (MCo co) = coercionSize co
|
|
2042 | + |
|
2006 | 2043 | {-
|
2007 | 2044 | ************************************************************************
|
2008 | 2045 | * *
|
... | ... | @@ -29,11 +29,10 @@ module GHC.Core.TyCo.Subst |
29 | 29 | mkTvSubstPrs,
|
30 | 30 | |
31 | 31 | substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,
|
32 | - substCoWith,
|
|
32 | + substCoWithInScope,
|
|
33 | 33 | substTy, substTyAddInScope, substScaledTy,
|
34 | 34 | substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked,
|
35 | 35 | substTyWithUnchecked, substScaledTyUnchecked,
|
36 | - substCoUnchecked, substCoWithUnchecked,
|
|
37 | 36 | substTyWithInScope,
|
38 | 37 | substTys, substScaledTys, substTheta,
|
39 | 38 | lookupTyVar,
|
... | ... | @@ -44,8 +43,8 @@ module GHC.Core.TyCo.Subst |
44 | 43 | substCoVarBndr, substDCoVarSet,
|
45 | 44 | substTyVar, substTyVars, substTyVarToTyVar,
|
46 | 45 | substTyCoVars,
|
47 | - substTyCoBndr, substForAllCoBndr,
|
|
48 | - substVarBndrUsing, substForAllCoBndrUsing,
|
|
46 | + substTyCoBndr,
|
|
47 | + substVarBndrUsing,
|
|
49 | 48 | checkValidSubst, isValidTCvSubst,
|
50 | 49 | ) where
|
51 | 50 | |
... | ... | @@ -60,7 +59,7 @@ import {-# SOURCE #-} GHC.Core.Coercion |
60 | 59 | , mkAxiomCo, mkAppCo, mkGReflCo
|
61 | 60 | , mkInstCo, mkLRCo, mkTyConAppCo
|
62 | 61 | , mkCoercionType
|
63 | - , coercionLKind, coVarTypesRole )
|
|
62 | + , coVarTypesRole )
|
|
64 | 63 | import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
|
65 | 64 | import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr
|
66 | 65 | import {-# SOURCE #-} GHC.Core ( CoreExpr )
|
... | ... | @@ -618,28 +617,19 @@ substTyWithUnchecked tvs tys |
618 | 617 | -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution
|
619 | 618 | -- invariant]; specifically it should include the free vars of 'tys',
|
620 | 619 | -- and of 'ty' minus the domain of the subst.
|
621 | -substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type
|
|
620 | +substTyWithInScope :: HasDebugCallStack
|
|
621 | + => InScopeSet -> [TyVar] -> [Type] -> Type -> Type
|
|
622 | 622 | substTyWithInScope in_scope tvs tys ty =
|
623 | 623 | assert (tvs `equalLength` tys )
|
624 | 624 | substTy (mkTvSubst in_scope tenv) ty
|
625 | 625 | where tenv = zipTyEnv tvs tys
|
626 | 626 | |
627 | 627 | -- | Coercion substitution, see 'zipTvSubst'
|
628 | -substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
|
|
629 | -substCoWith tvs tys = assert (tvs `equalLength` tys )
|
|
630 | - substCo (zipTvSubst tvs tys)
|
|
631 | - |
|
632 | --- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.
|
|
633 | --- The problems that the sanity checks in substCo catch are described in
|
|
634 | --- Note [The substitution invariant].
|
|
635 | --- The goal of #11371 is to migrate all the calls of substCoUnchecked to
|
|
636 | --- substCo and remove this function. Please don't use in new code.
|
|
637 | -substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion
|
|
638 | -substCoWithUnchecked tvs tys
|
|
628 | +substCoWithInScope :: HasDebugCallStack
|
|
629 | + => InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion
|
|
630 | +substCoWithInScope in_scope tvs tys co
|
|
639 | 631 | = assert (tvs `equalLength` tys )
|
640 | - substCoUnchecked (zipTvSubst tvs tys)
|
|
641 | - |
|
642 | - |
|
632 | + substCo (mkTvSubst in_scope (zipTyEnv tvs tys)) co
|
|
643 | 633 | |
644 | 634 | -- | Substitute covars within a type
|
645 | 635 | substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type
|
... | ... | @@ -800,10 +790,10 @@ subst_ty subst ty |
800 | 790 | !res' = go res
|
801 | 791 | in ty { ft_mult = mult', ft_arg = arg', ft_res = res' }
|
802 | 792 | go (ForAllTy (Bndr tv vis) ty)
|
803 | - = case substVarBndrUnchecked subst tv of
|
|
804 | - (subst', tv') ->
|
|
805 | - (ForAllTy $! ((Bndr $! tv') vis)) $!
|
|
806 | - (subst_ty subst' ty)
|
|
793 | + = (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty)
|
|
794 | + where
|
|
795 | + !(subst',tv') = substVarBndrUnchecked subst tv
|
|
796 | + -- Unchecked because subst_ty is used from substTyUnchecked
|
|
807 | 797 | go (LitTy n) = LitTy $! n
|
808 | 798 | go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co)
|
809 | 799 | go (CoercionTy co) = CoercionTy $! (subst_co subst co)
|
... | ... | @@ -850,16 +840,6 @@ substCo subst co |
850 | 840 | | isEmptyTCvSubst subst = co
|
851 | 841 | | otherwise = checkValidSubst subst [] [co] $ subst_co subst co
|
852 | 842 | |
853 | --- | Substitute within a 'Coercion' disabling sanity checks.
|
|
854 | --- The problems that the sanity checks in substCo catch are described in
|
|
855 | --- Note [The substitution invariant].
|
|
856 | --- The goal of #11371 is to migrate all the calls of substCoUnchecked to
|
|
857 | --- substCo and remove this function. Please don't use in new code.
|
|
858 | -substCoUnchecked :: Subst -> Coercion -> Coercion
|
|
859 | -substCoUnchecked subst co
|
|
860 | - | isEmptyTCvSubst subst = co
|
|
861 | - | otherwise = subst_co subst co
|
|
862 | - |
|
863 | 843 | -- | Substitute within several 'Coercion's
|
864 | 844 | -- The substitution has to satisfy the invariants described in
|
865 | 845 | -- Note [The substitution invariant].
|
... | ... | @@ -868,7 +848,7 @@ substCos subst cos |
868 | 848 | | isEmptyTCvSubst subst = cos
|
869 | 849 | | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos
|
870 | 850 | |
871 | -subst_co :: Subst -> Coercion -> Coercion
|
|
851 | +subst_co :: HasDebugCallStack => Subst -> Coercion -> Coercion
|
|
872 | 852 | subst_co subst co
|
873 | 853 | = go co
|
874 | 854 | where
|
... | ... | @@ -885,10 +865,14 @@ subst_co subst co |
885 | 865 | go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args
|
886 | 866 | go (AxiomCo con cos) = mkAxiomCo con $! go_cos cos
|
887 | 867 | go (AppCo co arg) = (mkAppCo $! go co) $! go arg
|
888 | - go (ForAllCo tv visL visR kind_co co)
|
|
889 | - = case substForAllCoBndrUnchecked subst tv kind_co of
|
|
890 | - (subst', tv', kind_co') ->
|
|
891 | - ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co
|
|
868 | + go (ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
|
|
869 | + , fco_kind = kind_co, fco_body = co })
|
|
870 | + = ((mkForAllCo $! tcv') visL visR
|
|
871 | + $! go_mco kind_co)
|
|
872 | + $! subst_co subst' co
|
|
873 | + where
|
|
874 | + !(subst', tcv') = substVarBndrUnchecked subst tcv
|
|
875 | + -- Unchecked because used from substTyUnchecked
|
|
892 | 876 | go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2
|
893 | 877 | go (CoVarCo cv) = substCoVar subst cv
|
894 | 878 | go (UnivCo { uco_prov = p, uco_role = r
|
... | ... | @@ -917,75 +901,6 @@ substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet |
917 | 901 | substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $
|
918 | 902 | dVarSetElems cvs
|
919 | 903 | |
920 | -substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion
|
|
921 | - -> (Subst, TyCoVar, Coercion)
|
|
922 | -substForAllCoBndr subst
|
|
923 | - = substForAllCoBndrUsing (substCo subst) subst
|
|
924 | - |
|
925 | --- | Like 'substForAllCoBndr', but disables sanity checks.
|
|
926 | --- The problems that the sanity checks in substCo catch are described in
|
|
927 | --- Note [The substitution invariant].
|
|
928 | --- The goal of #11371 is to migrate all the calls of substCoUnchecked to
|
|
929 | --- substCo and remove this function. Please don't use in new code.
|
|
930 | -substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion
|
|
931 | - -> (Subst, TyCoVar, Coercion)
|
|
932 | -substForAllCoBndrUnchecked subst
|
|
933 | - = substForAllCoBndrUsing (substCoUnchecked subst) subst
|
|
934 | - |
|
935 | --- See Note [Sym and ForAllCo]
|
|
936 | -substForAllCoBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
|
|
937 | - -> Subst -> TyCoVar -> KindCoercion
|
|
938 | - -> (Subst, TyCoVar, KindCoercion)
|
|
939 | -substForAllCoBndrUsing sco subst old_var
|
|
940 | - | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var
|
|
941 | - | otherwise = substForAllCoCoVarBndrUsing sco subst old_var
|
|
942 | - |
|
943 | -substForAllCoTyVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
|
|
944 | - -> Subst -> TyVar -> KindCoercion
|
|
945 | - -> (Subst, TyVar, KindCoercion)
|
|
946 | -substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
|
|
947 | - = assert (isTyVar old_var )
|
|
948 | - ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv
|
|
949 | - , new_var, new_kind_co )
|
|
950 | - where
|
|
951 | - new_env | no_change = delVarEnv tenv old_var
|
|
952 | - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
|
|
953 | - |
|
954 | - no_kind_change = noFreeVarsOfCo old_kind_co
|
|
955 | - no_change = no_kind_change && (new_var == old_var)
|
|
956 | - |
|
957 | - new_kind_co | no_kind_change = old_kind_co
|
|
958 | - | otherwise = sco old_kind_co
|
|
959 | - |
|
960 | - new_ki1 = coercionLKind new_kind_co
|
|
961 | - -- We could do substitution to (tyVarKind old_var). We don't do so because
|
|
962 | - -- we already substituted new_kind_co, which contains the kind information
|
|
963 | - -- we want. We don't want to do substitution once more. Also, in most cases,
|
|
964 | - -- new_kind_co is a Refl, in which case coercionKind is really fast.
|
|
965 | - |
|
966 | - new_var = uniqAway in_scope (setTyVarKind old_var new_ki1)
|
|
967 | - |
|
968 | -substForAllCoCoVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
|
|
969 | - -> Subst -> CoVar -> KindCoercion
|
|
970 | - -> (Subst, CoVar, KindCoercion)
|
|
971 | -substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv)
|
|
972 | - old_var old_kind_co
|
|
973 | - = assert (isCoVar old_var )
|
|
974 | - ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv
|
|
975 | - , new_var, new_kind_co )
|
|
976 | - where
|
|
977 | - new_cenv | no_change = delVarEnv cenv old_var
|
|
978 | - | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)
|
|
979 | - |
|
980 | - no_kind_change = noFreeVarsOfCo old_kind_co
|
|
981 | - no_change = no_kind_change && (new_var == old_var)
|
|
982 | - |
|
983 | - new_kind_co | no_kind_change = old_kind_co
|
|
984 | - | otherwise = sco old_kind_co
|
|
985 | - |
|
986 | - new_ki1 = coercionLKind new_kind_co
|
|
987 | - new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1
|
|
988 | - |
|
989 | 904 | substCoVar :: Subst -> CoVar -> Coercion
|
990 | 905 | substCoVar (Subst _ _ _ cenv) cv
|
991 | 906 | = case lookupVarEnv cenv cv of
|
... | ... | @@ -334,7 +334,7 @@ tidyCo env co |
334 | 334 | go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos
|
335 | 335 | go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
|
336 | 336 | go (ForAllCo tv visL visR h co)
|
337 | - = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)
|
|
337 | + = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go_mco h)) $! (tidyCo envp co)
|
|
338 | 338 | where (envp, tvp) = tidyVarBndr env tv
|
339 | 339 | -- the case above duplicates a bit of work in tidying h and the kind
|
340 | 340 | -- of tv. But the alternative is to use coercionKind, which seems worse.
|
... | ... | @@ -210,7 +210,7 @@ module GHC.Core.Type ( |
210 | 210 | substTyAddInScope,
|
211 | 211 | substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,
|
212 | 212 | substThetaUnchecked, substTyWithUnchecked,
|
213 | - substCo, substCoUnchecked, substCoWithUnchecked,
|
|
213 | + substCo, substCoWithInScope,
|
|
214 | 214 | substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
|
215 | 215 | substVarBndr, substVarBndrs,
|
216 | 216 | substTyCoBndr, substTyVarToTyVar,
|
... | ... | @@ -530,10 +530,13 @@ expandTypeSynonyms ty |
530 | 530 | = mkTyConAppCo r tc (map (go_co subst) args)
|
531 | 531 | go_co subst (AppCo co arg)
|
532 | 532 | = mkAppCo (go_co subst co) (go_co subst arg)
|
533 | - go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
|
|
533 | + go_co subst (ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
|
|
534 | 534 | , fco_kind = kind_co, fco_body = co })
|
535 | - = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in
|
|
536 | - mkForAllCo tv' visL visR kind_co' (go_co subst' co)
|
|
535 | + = mkForAllCo tcv' visL visR
|
|
536 | + (go_mco subst kind_co)
|
|
537 | + (go_co subst' co)
|
|
538 | + where
|
|
539 | + (subst', tcv') = substVarBndr subst tcv
|
|
537 | 540 | go_co subst (FunCo r afl afr w co1 co2)
|
538 | 541 | = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)
|
539 | 542 | go_co subst (CoVarCo cv)
|
... | ... | @@ -559,8 +562,6 @@ expandTypeSynonyms ty |
559 | 562 | go_co _ (HoleCo h)
|
560 | 563 | = pprPanic "expandTypeSynonyms hit a hole" (ppr h)
|
561 | 564 | |
562 | - go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst
|
|
563 | - |
|
564 | 565 | {- Notes on type synonyms
|
565 | 566 | ~~~~~~~~~~~~~~~~~~~~~~~~~
|
566 | 567 | The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
|
... | ... | @@ -971,7 +972,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar |
971 | 972 | = mkTyConAppCo r tc <$> go_cos env cos
|
972 | 973 | go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
|
973 | 974 | , fco_kind = kind_co, fco_body = co })
|
974 | - = do { kind_co' <- go_co env kind_co
|
|
975 | + = do { kind_co' <- go_mco env kind_co
|
|
975 | 976 | ; tycobinder env tv visL $ \env' tv' -> do
|
976 | 977 | ; co' <- go_co env' co
|
977 | 978 | ; return $ mkForAllCo tv' visL visR kind_co' co' }
|
... | ... | @@ -2414,14 +2414,15 @@ ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) |
2414 | 2414 | -- not doing so caused #21205.
|
2415 | 2415 | |
2416 | 2416 | ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)
|
2417 | - (ForAllCo tv2 vis1c vis2c kind_co2 co2)
|
|
2417 | + (ForAllCo tv2 vis1c vis2c kind_mco2 co2)
|
|
2418 | 2418 | lkco rkco
|
2419 | 2419 | | isTyVar tv1 && isTyVar tv2
|
2420 | 2420 | , vis1t == vis1c && vis1c == vis2c -- Is this necessary?
|
2421 | 2421 | -- Is this visibility check necessary? @rae says: yes, I think the
|
2422 | 2422 | -- check is necessary, if we're caring about visibility (and we are).
|
2423 | 2423 | -- But ty_co_match is a dark and not important corner.
|
2424 | - = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2
|
|
2424 | + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1)
|
|
2425 | + (forAllCoKindCo tv2 kind_mco2)
|
|
2425 | 2426 | ki_ki_co ki_ki_co
|
2426 | 2427 | ; let rn_env0 = me_env menv
|
2427 | 2428 | rn_env1 = rnBndr2 rn_env0 tv1 tv2
|
... | ... | @@ -2522,6 +2523,6 @@ pushRefl co = |
2522 | 2523 | -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))
|
2523 | 2524 | Just (ForAllTy (Bndr tv vis) ty, r)
|
2524 | 2525 | -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis
|
2525 | - , fco_kind = mkNomReflCo (varType tv)
|
|
2526 | + , fco_kind = MRefl
|
|
2526 | 2527 | , fco_body = mkReflCo r ty })
|
2527 | 2528 | _ -> Nothing |
... | ... | @@ -312,7 +312,7 @@ toIfaceCoercionX fr co |
312 | 312 | = IfaceForAllCo (toIfaceBndr tv)
|
313 | 313 | visL
|
314 | 314 | visR
|
315 | - (toIfaceCoercionX fr' k)
|
|
315 | + (go_mco k)
|
|
316 | 316 | (toIfaceCoercionX fr' co)
|
317 | 317 | where
|
318 | 318 | fr' = fr `delVarSet` tv
|
... | ... | @@ -689,7 +689,7 @@ rnIfaceCo (IfaceAxiomCo ax cos) = IfaceAxiomCo ax <$> mapM rnIfaceCo cos |
689 | 689 | rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
|
690 | 690 | rnIfaceCo (IfaceForAllCo bndr visL visR co1 co2)
|
691 | 691 | = (\bndr' co1' co2' -> IfaceForAllCo bndr' visL visR co1' co2')
|
692 | - <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
|
|
692 | + <$> rnIfaceBndr bndr <*> rnIfaceMCo co1 <*> rnIfaceCo co2
|
|
693 | 693 | rnIfaceCo (IfaceUnivCo s r t1 t2 deps)
|
694 | 694 | = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 <*> mapM rnIfaceCo deps
|
695 | 695 |
... | ... | @@ -2076,7 +2076,7 @@ freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) |
2076 | 2076 | freeNamesIfCoercion (IfaceAppCo c1 c2)
|
2077 | 2077 | = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
|
2078 | 2078 | freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co)
|
2079 | - = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
|
|
2079 | + = freeNamesIfMCoercion kind_co &&& freeNamesIfCoercion co
|
|
2080 | 2080 | freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
|
2081 | 2081 | freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet
|
2082 | 2082 | freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet
|
... | ... | @@ -132,7 +132,7 @@ data IfaceBndr -- Local (non-top-level) binders |
132 | 132 | deriving (Eq, Ord)
|
133 | 133 | |
134 | 134 | |
135 | -type IfaceIdBndr = (IfaceType, IfLclName, IfaceType)
|
|
135 | +type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) -- (multiplicity, name, type)
|
|
136 | 136 | type IfaceTvBndr = (IfLclName, IfaceKind)
|
137 | 137 | |
138 | 138 | ifaceTvBndrName :: IfaceTvBndr -> IfLclName
|
... | ... | @@ -479,7 +479,7 @@ data IfaceCoercion |
479 | 479 | | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion
|
480 | 480 | | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
|
481 | 481 | | IfaceAppCo IfaceCoercion IfaceCoercion
|
482 | - | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion
|
|
482 | + | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceMCoercion IfaceCoercion
|
|
483 | 483 | | IfaceCoVarCo IfLclName
|
484 | 484 | | IfaceAxiomCo IfaceAxiomRule [IfaceCoercion]
|
485 | 485 | -- ^ There are only a fixed number of CoAxiomRules, so it suffices
|
... | ... | @@ -1454,10 +1454,9 @@ pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc |
1454 | 1454 | pprIfaceForAllPartMust tvs ctxt sdoc
|
1455 | 1455 | = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
|
1456 | 1456 | |
1457 | -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)]
|
|
1457 | +pprIfaceForAllCoPart :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)]
|
|
1458 | 1458 | -> SDoc -> SDoc
|
1459 | -pprIfaceForAllCoPart tvs sdoc
|
|
1460 | - = sep [ pprIfaceForAllCo tvs, sdoc ]
|
|
1459 | +pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs, sdoc ]
|
|
1461 | 1460 | |
1462 | 1461 | ppr_iface_forall_part :: ShowForAllFlag
|
1463 | 1462 | -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
|
... | ... | @@ -1494,11 +1493,11 @@ ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 |
1494 | 1493 | | otherwise = (all_bndrs, [])
|
1495 | 1494 | ppr_itv_bndrs [] _ = ([], [])
|
1496 | 1495 | |
1497 | -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
|
|
1496 | +pprIfaceForAllCo :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
|
|
1498 | 1497 | pprIfaceForAllCo [] = empty
|
1499 | 1498 | pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
|
1500 | 1499 | |
1501 | -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
|
|
1500 | +pprIfaceForAllCoBndrs :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
|
|
1502 | 1501 | pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
|
1503 | 1502 | |
1504 | 1503 | pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
|
... | ... | @@ -1513,10 +1512,17 @@ pprIfaceForAllBndr bndr = |
1513 | 1512 | -- See Note [Suppressing binder signatures]
|
1514 | 1513 | suppress_sig = SuppressBndrSig False
|
1515 | 1514 | |
1516 | -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc
|
|
1517 | -pprIfaceForAllCoBndr (tv, kind_co, visL, visR)
|
|
1518 | - = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co)
|
|
1515 | +pprIfaceForAllCoBndr :: (IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc
|
|
1516 | +pprIfaceForAllCoBndr (tcv, kind_mco, visL, visR)
|
|
1517 | + = parens (ppr (ifaceBndrName tcv) <> pp_vis
|
|
1518 | + <+> text "::~" <+> pprIfaceCoercion kind_co)
|
|
1519 | + -- We print (tcv ::~ kind_co), with the "::~" reminding us the type of tcv
|
|
1520 | + -- isn't kind_co; rather it's (coercionLKind kind_co). We used "::" previously
|
|
1521 | + -- which grievously confused me.
|
|
1519 | 1522 | where
|
1523 | + kind_co = case kind_mco of
|
|
1524 | + IfaceMRefl -> IfaceReflCo (ifaceBndrType tcv)
|
|
1525 | + IfaceMCo co -> co
|
|
1520 | 1526 | pp_vis | visL == coreTyLamForAllTyFlag
|
1521 | 1527 | , visR == coreTyLamForAllTyFlag
|
1522 | 1528 | = empty
|
... | ... | @@ -2069,10 +2075,8 @@ ppr_co ctxt_prec co@(IfaceForAllCo {}) |
2069 | 2075 | where
|
2070 | 2076 | (tvs, inner_co) = split_co co
|
2071 | 2077 | |
2072 | - split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co')
|
|
2073 | - = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')
|
|
2074 | - split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co')
|
|
2075 | - = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')
|
|
2078 | + split_co (IfaceForAllCo bndr visL visR kind_co co')
|
|
2079 | + = let (tvs, co'') = split_co co' in ((bndr,kind_co,visL,visR):tvs,co'')
|
|
2076 | 2080 | split_co co' = ([], co')
|
2077 | 2081 | |
2078 | 2082 | -- Why these three? See Note [Free TyVars and CoVars in IfaceType]
|
... | ... | @@ -1576,9 +1576,12 @@ tcIfaceCo = go |
1576 | 1576 | go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2
|
1577 | 1577 | go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
|
1578 | 1578 | go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
|
1579 | - go (IfaceForAllCo tv visL visR k c) = do { k' <- go k
|
|
1580 | - ; bindIfaceBndr tv $ \ tv' ->
|
|
1581 | - ForAllCo tv' visL visR k' <$> go c }
|
|
1579 | + go (IfaceForAllCo tcv visL visR k co)
|
|
1580 | + = do { k' <- go_mco k
|
|
1581 | + ; bindIfaceBndr tcv $ \ tv' ->
|
|
1582 | + do { co' <- go co
|
|
1583 | + ; return (ForAllCo { fco_tcv = tv', fco_visL = visL, fco_visR = visR
|
|
1584 | + , fco_kind = k', fco_body = co' }) } }
|
|
1582 | 1585 | go (IfaceCoVarCo n) = CoVarCo <$> go_var n
|
1583 | 1586 | go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2
|
1584 | 1587 | ; ds' <- mapM go ds
|
... | ... | @@ -135,7 +135,7 @@ synonymTyConsOfType ty |
135 | 135 | go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs
|
136 | 136 | go_co (AppCo co co') = go_co co `plusNameEnv` go_co co'
|
137 | 137 | go_co (ForAllCo { fco_kind = kind_co, fco_body = body_co })
|
138 | - = go_co kind_co `plusNameEnv` go_co body_co
|
|
138 | + = go_mco kind_co `plusNameEnv` go_co body_co
|
|
139 | 139 | go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
|
140 | 140 | = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r
|
141 | 141 | go_co (CoVarCo _) = emptyNameEnv
|
... | ... | @@ -1586,7 +1586,7 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co |
1586 | 1586 | go_co dv (CoVarCo cv) = go_cv dv cv
|
1587 | 1587 | |
1588 | 1588 | go_co dv (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co })
|
1589 | - = do { dv1 <- go_co dv kind_co
|
|
1589 | + = do { dv1 <- go_mco dv kind_co
|
|
1590 | 1590 | ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co }
|
1591 | 1591 | |
1592 | 1592 | go_mco dv MRefl = return dv
|
... | ... | @@ -176,7 +176,6 @@ module GHC.Tc.Utils.TcType ( |
176 | 176 | substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
|
177 | 177 | substThetaUnchecked,
|
178 | 178 | substTyWithUnchecked,
|
179 | - substCoUnchecked, substCoWithUnchecked,
|
|
180 | 179 | substTheta,
|
181 | 180 | |
182 | 181 | isUnliftedType,
|
... | ... | @@ -1206,10 +1206,11 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty |
1206 | 1206 | boxer = Boxer $ \ subst ->
|
1207 | 1207 | do { (rep_ids, rep_expr)
|
1208 | 1208 | <- case box_rep of
|
1209 | - UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx") (linear $ TcType.substTy subst rep_ty)
|
|
1209 | + UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx")
|
|
1210 | + (linear $ TcType.substTy subst rep_ty)
|
|
1210 | 1211 | ; return ([rep_id], Var rep_id) }
|
1211 | 1212 | Boxer boxer -> boxer subst
|
1212 | - ; let sco = substCoUnchecked subst co
|
|
1213 | + ; let sco = substCo subst co
|
|
1213 | 1214 | ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
|
1214 | 1215 | |
1215 | 1216 | ------------------------
|
1 | 1 | |
2 | 2 | ==================== Tidy Core ====================
|
3 | 3 | Result size of Tidy Core
|
4 | - = {terms: 82, types: 52, coercions: 29, joins: 0/0}
|
|
4 | + = {terms: 82, types: 52, coercions: 26, joins: 0/0}
|
|
5 | 5 | |
6 | 6 | -- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0}
|
7 | 7 | unsafeToInteger1 :: forall (n :: Nat). Signed n -> Signed n
|
8 | 8 | [GblId, Arity=1, Unf=OtherCon []]
|
9 | 9 | unsafeToInteger1 = \ (@(n :: Nat)) (ds :: Signed n) -> ds
|
10 | 10 | |
11 | --- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0}
|
|
11 | +-- RHS size: {terms: 1, types: 0, coercions: 7, joins: 0/0}
|
|
12 | 12 | unsafeToInteger :: forall (n :: Nat). Signed n -> Integer
|
13 | 13 | [GblId[[RecSel]], Arity=1, Unf=OtherCon []]
|
14 | 14 | unsafeToInteger
|
15 | 15 | = unsafeToInteger1
|
16 | - `cast` (forall (n :: <Nat>_N).
|
|
16 | + `cast` (forall (n ::~ <Nat>_N).
|
|
17 | 17 | <Signed n>_R %<Many>_N ->_R OpaqueNoCastWW.N:Signed <n>_P
|
18 | 18 | :: (forall (n :: Nat). Signed n -> Signed n)
|
19 | 19 | ~R# (forall (n :: Nat). Signed n -> Integer))
|
20 | 20 | |
21 | --- RHS size: {terms: 8, types: 7, coercions: 21, joins: 0/0}
|
|
21 | +-- RHS size: {terms: 8, types: 7, coercions: 19, joins: 0/0}
|
|
22 | 22 | times [InlPrag=OPAQUE]
|
23 | 23 | :: forall (m :: Nat) (n :: Nat).
|
24 | 24 | Signed m -> Signed n -> Signed (m + n)
|
... | ... | @@ -33,7 +33,7 @@ times |
33 | 33 | (ds `cast` (OpaqueNoCastWW.N:Signed <m>_P :: Signed m ~R# Integer))
|
34 | 34 | (ds1
|
35 | 35 | `cast` (OpaqueNoCastWW.N:Signed <n>_P :: Signed n ~R# Integer)))
|
36 | - `cast` (forall (m :: <Nat>_N) (n :: <Nat>_N).
|
|
36 | + `cast` (forall (m ::~ <Nat>_N) (n ::~ <Nat>_N).
|
|
37 | 37 | <Signed m>_R
|
38 | 38 | %<Many>_N ->_R <Signed n>_R
|
39 | 39 | %<Many>_N ->_R Sym (OpaqueNoCastWW.N:Signed <m + n>_P)
|