Simon Peyton Jones pushed to branch wip/T26369 at Glasgow Haskell Compiler / GHC

Commits:

22 changed files:

Changes:

  • compiler/GHC/Core/Coercion.hs
    ... ... @@ -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)
    

  • compiler/GHC/Core/Coercion.hs-boot
    ... ... @@ -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)
    

  • compiler/GHC/Core/Coercion/Opt.hs
    ... ... @@ -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
     {- **********************************************************************
    

  • compiler/GHC/Core/Lint.hs
    ... ... @@ -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)
    

  • compiler/GHC/Core/Opt/Arity.hs
    ... ... @@ -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
    

  • compiler/GHC/Core/Reduction.hs
    ... ... @@ -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'
    

  • compiler/GHC/Core/TyCo/FVs.hs
    ... ... @@ -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
    

  • compiler/GHC/Core/TyCo/Rep.hs
    ... ... @@ -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
     *                                                                      *
    

  • compiler/GHC/Core/TyCo/Subst.hs
    ... ... @@ -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
    

  • compiler/GHC/Core/TyCo/Tidy.hs
    ... ... @@ -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.
    

  • compiler/GHC/Core/Type.hs
    ... ... @@ -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' }
    

  • compiler/GHC/Core/Unify.hs
    ... ... @@ -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

  • compiler/GHC/CoreToIface.hs
    ... ... @@ -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
    

  • compiler/GHC/Iface/Rename.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Iface/Syntax.hs
    ... ... @@ -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
    

  • compiler/GHC/Iface/Type.hs
    ... ... @@ -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]
    

  • compiler/GHC/IfaceToCore.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/TyCl/Utils.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Utils/TcMType.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Utils/TcType.hs
    ... ... @@ -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,
    

  • compiler/GHC/Types/Id/Make.hs
    ... ... @@ -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
     ------------------------
    

  • testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
    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)