Commit 55a3f855 authored by Ningning Xie's avatar Ningning Xie Committed by Richard Eisenberg
Browse files

Refactor coercion rule

Summary:
The patch is an attempt on #15192.

It defines a new coercion rule

```
 | GRefl Role Type MCoercion
```

which correspondes to the typing rule

```
     t1 : k1
  ------------------------------------
  GRefl r t1 MRefl: t1 ~r t1

     t1 : k1       co :: k1 ~ k2
  ------------------------------------
  GRefl r t1 (MCo co) : t1 ~r t1 |> co
```

MCoercion wraps a coercion, which might be reflexive (MRefl)
or not (MCo co). To know more about MCoercion see #14975.

We keep Refl ty as a special case for nominal reflexive coercions,
naemly, Refl ty :: ty ~n ty.

This commit is meant to be a general performance improvement,
but there are a few regressions. See #15192, comment:13 for
more information.

Test Plan: ./validate

Reviewers: bgamari, goldfire, simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15192

Differential Revision: https://phabricator.haskell.org/D4747
parent 6595bee7
...@@ -641,8 +641,14 @@ rnIfaceLetBndr (IfLetBndr fs ty info jpi) ...@@ -641,8 +641,14 @@ rnIfaceLetBndr (IfLetBndr fs ty info jpi)
rnIfaceLamBndr :: Rename IfaceLamBndr rnIfaceLamBndr :: Rename IfaceLamBndr
rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
rnIfaceMCo :: Rename IfaceMCoercion
rnIfaceMCo IfaceMRefl = pure IfaceMRefl
rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
rnIfaceCo :: Rename IfaceCoercion rnIfaceCo :: Rename IfaceCoercion
rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
rnIfaceCo (IfaceGReflCo role ty mco)
= IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
rnIfaceCo (IfaceFunCo role co1 co2) rnIfaceCo (IfaceFunCo role co1 co2)
= IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
rnIfaceCo (IfaceTyConAppCo role tc cos) rnIfaceCo (IfaceTyConAppCo role tc cos)
...@@ -670,7 +676,6 @@ rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c ...@@ -670,7 +676,6 @@ rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
rnIfaceCo (IfaceAxiomRuleCo ax cos) rnIfaceCo (IfaceAxiomRuleCo ax cos)
= IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
rnIfaceTyCon :: Rename IfaceTyCon rnIfaceTyCon :: Rename IfaceTyCon
rnIfaceTyCon (IfaceTyCon n info) rnIfaceTyCon (IfaceTyCon n info)
......
...@@ -366,8 +366,13 @@ orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet ...@@ -366,8 +366,13 @@ orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
orphNamesOfTypes :: [Type] -> NameSet orphNamesOfTypes :: [Type] -> NameSet
orphNamesOfTypes = orphNamesOfThings orphNamesOfType orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfMCo :: MCoercion -> NameSet
orphNamesOfMCo MRefl = emptyNameSet
orphNamesOfMCo (MCo co) = orphNamesOfCo co
orphNamesOfCo :: Coercion -> NameSet orphNamesOfCo :: Coercion -> NameSet
orphNamesOfCo (Refl _ ty) = orphNamesOfType ty orphNamesOfCo (Refl ty) = orphNamesOfType ty
orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco
orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co) orphNamesOfCo (ForAllCo _ kind_co co)
...@@ -381,7 +386,6 @@ orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNames ...@@ -381,7 +386,6 @@ orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNames
orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (KindCo co) = orphNamesOfCo co orphNamesOfCo (KindCo co) = orphNamesOfCo co
orphNamesOfCo (SubCo co) = orphNamesOfCo co orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
......
...@@ -1617,15 +1617,28 @@ lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, Linted ...@@ -1617,15 +1617,28 @@ lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, Linted
-- --
-- If lintCoercion co = (k1, k2, s1, s2, r) -- If lintCoercion co = (k1, k2, s1, s2, r)
-- then co :: s1 ~r s2 -- then co :: s1 ~r s2
-- s1 :: k2 -- s1 :: k1
-- s2 :: k2 -- s2 :: k2
-- If you edit this function, you may need to update the GHC formalism -- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] -- See Note [GHC Formalism]
lintCoercion (Refl r ty) lintCoercion (Refl ty)
= do { k <- lintType ty
; return (k, k, ty, ty, Nominal) }
lintCoercion (GRefl r ty MRefl)
= do { k <- lintType ty = do { k <- lintType ty
; return (k, k, ty, ty, r) } ; return (k, k, ty, ty, r) }
lintCoercion (GRefl r ty (MCo co))
= do { k <- lintType ty
; (_, _, k1, k2, r') <- lintCoercion co
; ensureEqTys k k1
(hang (text "GRefl coercion kind mis-match:" <+> ppr co)
2 (vcat [ppr ty, ppr k, ppr k1]))
; lintRole co Nominal r'
; return (k1, k2, ty, mkCastTy ty co, r) }
lintCoercion co@(TyConAppCo r tc cos) lintCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey | tc `hasKey` funTyConKey
, [_rep1,_rep2,_co1,_co2] <- cos , [_rep1,_rep2,_co1,_co2] <- cos
...@@ -1646,7 +1659,7 @@ lintCoercion co@(TyConAppCo r tc cos) ...@@ -1646,7 +1659,7 @@ lintCoercion co@(TyConAppCo r tc cos)
lintCoercion co@(AppCo co1 co2) lintCoercion co@(AppCo co1 co2)
| TyConAppCo {} <- co1 | TyConAppCo {} <- co1
= failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
| Refl _ (TyConApp {}) <- co1 | Just (TyConApp {}, _) <- isReflCo_maybe co1
= failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
| otherwise | otherwise
= do { (k1, k2, s1, s2, r1) <- lintCoercion co1 = do { (k1, k2, s1, s2, r1) <- lintCoercion co1
...@@ -1884,12 +1897,6 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -1884,12 +1897,6 @@ lintCoercion co@(AxiomInstCo con ind cos)
; return (extendTCvSubst subst_l ktv s', ; return (extendTCvSubst subst_l ktv s',
extendTCvSubst subst_r ktv t') } extendTCvSubst subst_r ktv t') }
lintCoercion (CoherenceCo co1 co2)
= do { (_, k2, t1, t2, r) <- lintCoercion co1
; let lhsty = mkCastTy t1 co2
; k1' <- lintType lhsty
; return (k1', k2, lhsty, t2, r) }
lintCoercion (KindCo co) lintCoercion (KindCo co)
= do { (k1, k2, _, _, _) <- lintCoercion co = do { (k1, k2, _, _, _) <- lintCoercion co
; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
......
...@@ -995,7 +995,7 @@ pushCoTyArg co ty ...@@ -995,7 +995,7 @@ pushCoTyArg co ty
-- kinds of the types related by a coercion between forall-types. -- kinds of the types related by a coercion between forall-types.
-- See the NthCo case in CoreLint. -- See the NthCo case in CoreLint.
co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1) co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)
-- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
-- Arg of mkInstCo is always nominal, hence mkNomReflCo -- Arg of mkInstCo is always nominal, hence mkNomReflCo
......
...@@ -1425,8 +1425,14 @@ freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t ...@@ -1425,8 +1425,14 @@ freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
freeNamesIfMCoercion IfaceMRefl = emptyNameSet
freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co
freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion :: IfaceCoercion -> NameSet
freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t
freeNamesIfCoercion (IfaceGReflCo _ t mco)
= freeNamesIfType t &&& freeNamesIfMCoercion mco
freeNamesIfCoercion (IfaceFunCo _ c1 c2) freeNamesIfCoercion (IfaceFunCo _ c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
...@@ -1452,8 +1458,6 @@ freeNamesIfCoercion (IfaceLRCo _ co) ...@@ -1452,8 +1458,6 @@ freeNamesIfCoercion (IfaceLRCo _ co)
= freeNamesIfCoercion co = freeNamesIfCoercion co
freeNamesIfCoercion (IfaceInstCo co co2) freeNamesIfCoercion (IfaceInstCo co co2)
= freeNamesIfCoercion co &&& freeNamesIfCoercion co2 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceKindCo c) freeNamesIfCoercion (IfaceKindCo c)
= freeNamesIfCoercion c = freeNamesIfCoercion c
freeNamesIfCoercion (IfaceSubCo co) freeNamesIfCoercion (IfaceSubCo co)
......
...@@ -14,6 +14,7 @@ module IfaceType ( ...@@ -14,6 +14,7 @@ module IfaceType (
IfExtName, IfLclName, IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceMCoercion(..),
IfaceUnivCoProv(..), IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..), IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
IfaceTyLit(..), IfaceTcArgs(..), IfaceTyLit(..), IfaceTcArgs(..),
...@@ -280,8 +281,13 @@ data IfaceTyConInfo -- Used to guide pretty-printing ...@@ -280,8 +281,13 @@ data IfaceTyConInfo -- Used to guide pretty-printing
, ifaceTyConSort :: IfaceTyConSort } , ifaceTyConSort :: IfaceTyConSort }
deriving (Eq) deriving (Eq)
data IfaceMCoercion
= IfaceMRefl
| IfaceMCo IfaceCoercion
data IfaceCoercion data IfaceCoercion
= IfaceReflCo Role IfaceType = IfaceReflCo IfaceType
| IfaceGReflCo Role IfaceType (IfaceMCoercion)
| IfaceFunCo Role IfaceCoercion IfaceCoercion | IfaceFunCo Role IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion | IfaceAppCo IfaceCoercion IfaceCoercion
...@@ -298,7 +304,6 @@ data IfaceCoercion ...@@ -298,7 +304,6 @@ data IfaceCoercion
| IfaceNthCo Int IfaceCoercion | IfaceNthCo Int IfaceCoercion
| IfaceLRCo LeftOrRight IfaceCoercion | IfaceLRCo LeftOrRight IfaceCoercion
| IfaceInstCo IfaceCoercion IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion
| IfaceCoherenceCo IfaceCoercion IfaceCoercion
| IfaceKindCo IfaceCoercion | IfaceKindCo IfaceCoercion
| IfaceSubCo IfaceCoercion | IfaceSubCo IfaceCoercion
| IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType]
...@@ -457,8 +462,12 @@ substIfaceType env ty ...@@ -457,8 +462,12 @@ substIfaceType env ty
go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty) go_mco IfaceMRefl = IfaceMRefl
go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) go_mco (IfaceMCo co) = IfaceMCo $ go_co co
go_co (IfaceReflCo ty) = IfaceReflCo (go ty)
go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco)
go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
...@@ -472,7 +481,6 @@ substIfaceType env ty ...@@ -472,7 +481,6 @@ substIfaceType env ty
go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
go_co (IfaceKindCo co) = IfaceKindCo (go_co co) go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
go_co (IfaceSubCo co) = IfaceSubCo (go_co co) go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
...@@ -1197,7 +1205,12 @@ pprIfaceCoercion = ppr_co topPrec ...@@ -1197,7 +1205,12 @@ pprIfaceCoercion = ppr_co topPrec
pprParendIfaceCoercion = ppr_co appPrec pprParendIfaceCoercion = ppr_co appPrec
ppr_co :: PprPrec -> IfaceCoercion -> SDoc ppr_co :: PprPrec -> IfaceCoercion -> SDoc
ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal
ppr_co _ (IfaceGReflCo r ty IfaceMRefl)
= angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co))
= ppr_special_co ctxt_prec
(text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co]
ppr_co ctxt_prec (IfaceFunCo r co1 co2) ppr_co ctxt_prec (IfaceFunCo r co1 co2)
= maybeParen ctxt_prec funPrec $ = maybeParen ctxt_prec funPrec $
sep (ppr_co funPrec co1 : ppr_fun_tail co2) sep (ppr_co funPrec co1 : ppr_fun_tail co2)
...@@ -1258,8 +1271,6 @@ ppr_co ctxt_prec (IfaceLRCo lr co) ...@@ -1258,8 +1271,6 @@ ppr_co ctxt_prec (IfaceLRCo lr co)
= ppr_special_co ctxt_prec (ppr lr) [co] = ppr_special_co ctxt_prec (ppr lr) [co]
ppr_co ctxt_prec (IfaceSubCo co) ppr_co ctxt_prec (IfaceSubCo co)
= ppr_special_co ctxt_prec (text "Sub") [co] = ppr_special_co ctxt_prec (text "Sub") [co]
ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
= ppr_special_co ctxt_prec (text "Coh") [co1,co2]
ppr_co ctxt_prec (IfaceKindCo co) ppr_co ctxt_prec (IfaceKindCo co)
= ppr_special_co ctxt_prec (text "Kind") [co] = ppr_special_co ctxt_prec (text "Kind") [co]
...@@ -1490,64 +1501,79 @@ instance Binary IfaceType where ...@@ -1490,64 +1501,79 @@ instance Binary IfaceType where
_ -> do n <- get bh _ -> do n <- get bh
return (IfaceLitTy n) return (IfaceLitTy n)
instance Binary IfaceMCoercion where
put_ bh IfaceMRefl = do
putByte bh 1
put_ bh (IfaceMCo co) = do
putByte bh 2
put_ bh co
get bh = do
tag <- getByte bh
case tag of
1 -> return IfaceMRefl
2 -> do a <- get bh
return $ IfaceMCo a
_ -> panic ("get IfaceMCoercion " ++ show tag)
instance Binary IfaceCoercion where instance Binary IfaceCoercion where
put_ bh (IfaceReflCo a b) = do put_ bh (IfaceReflCo a) = do
putByte bh 1 putByte bh 1
put_ bh a put_ bh a
put_ bh (IfaceGReflCo a b c) = do
putByte bh 2
put_ bh a
put_ bh b put_ bh b
put_ bh c
put_ bh (IfaceFunCo a b c) = do put_ bh (IfaceFunCo a b c) = do
putByte bh 2 putByte bh 3
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh c put_ bh c
put_ bh (IfaceTyConAppCo a b c) = do put_ bh (IfaceTyConAppCo a b c) = do
putByte bh 3 putByte bh 4
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh c put_ bh c
put_ bh (IfaceAppCo a b) = do put_ bh (IfaceAppCo a b) = do
putByte bh 4 putByte bh 5
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh (IfaceForAllCo a b c) = do put_ bh (IfaceForAllCo a b c) = do
putByte bh 5 putByte bh 6
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh c put_ bh c
put_ bh (IfaceCoVarCo a) = do put_ bh (IfaceCoVarCo a) = do
putByte bh 6 putByte bh 7
put_ bh a put_ bh a
put_ bh (IfaceAxiomInstCo a b c) = do put_ bh (IfaceAxiomInstCo a b c) = do
putByte bh 7 putByte bh 8
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh c put_ bh c
put_ bh (IfaceUnivCo a b c d) = do put_ bh (IfaceUnivCo a b c d) = do
putByte bh 8 putByte bh 9
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh c put_ bh c
put_ bh d put_ bh d
put_ bh (IfaceSymCo a) = do put_ bh (IfaceSymCo a) = do
putByte bh 9
put_ bh a
put_ bh (IfaceTransCo a b) = do
putByte bh 10 putByte bh 10
put_ bh a put_ bh a
put_ bh b put_ bh (IfaceTransCo a b) = do
put_ bh (IfaceNthCo a b) = do
putByte bh 11 putByte bh 11
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh (IfaceLRCo a b) = do put_ bh (IfaceNthCo a b) = do
putByte bh 12 putByte bh 12
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh (IfaceInstCo a b) = do put_ bh (IfaceLRCo a b) = do
putByte bh 13 putByte bh 13
put_ bh a put_ bh a
put_ bh b put_ bh b
put_ bh (IfaceCoherenceCo a b) = do put_ bh (IfaceInstCo a b) = do
putByte bh 14 putByte bh 14
put_ bh a put_ bh a
put_ bh b put_ bh b
...@@ -1571,51 +1597,51 @@ instance Binary IfaceCoercion where ...@@ -1571,51 +1597,51 @@ instance Binary IfaceCoercion where
tag <- getByte bh tag <- getByte bh
case tag of case tag of
1 -> do a <- get bh 1 -> do a <- get bh
b <- get bh return $ IfaceReflCo a
return $ IfaceReflCo a b
2 -> do a <- get bh 2 -> do a <- get bh
b <- get bh b <- get bh
c <- get bh c <- get bh
return $ IfaceFunCo a b c return $ IfaceGReflCo a b c
3 -> do a <- get bh 3 -> do a <- get bh
b <- get bh b <- get bh
c <- get bh c <- get bh
return $ IfaceTyConAppCo a b c return $ IfaceFunCo a b c
4 -> do a <- get bh 4 -> do a <- get bh
b <- get bh b <- get bh
return $ IfaceAppCo a b c <- get bh
return $ IfaceTyConAppCo a b c
5 -> do a <- get bh 5 -> do a <- get bh
b <- get bh
return $ IfaceAppCo a b
6 -> do a <- get bh
b <- get bh b <- get bh
c <- get bh c <- get bh
return $ IfaceForAllCo a b c return $ IfaceForAllCo a b c
6 -> do a <- get bh
return $ IfaceCoVarCo a
7 -> do a <- get bh 7 -> do a <- get bh
return $ IfaceCoVarCo a
8 -> do a <- get bh
b <- get bh b <- get bh
c <- get bh c <- get bh
return $ IfaceAxiomInstCo a b c return $ IfaceAxiomInstCo a b c
8 -> do a <- get bh 9 -> do a <- get bh
b <- get bh b <- get bh
c <- get bh c <- get bh
d <- get bh d <- get bh
return $ IfaceUnivCo a b c d return $ IfaceUnivCo a b c d
9 -> do a <- get bh
return $ IfaceSymCo a
10-> do a <- get bh 10-> do a <- get bh
b <- get bh return $ IfaceSymCo a
return $ IfaceTransCo a b
11-> do a <- get bh 11-> do a <- get bh
b <- get bh b <- get bh
return $ IfaceNthCo a b return $ IfaceTransCo a b
12-> do a <- get bh 12-> do a <- get bh
b <- get bh b <- get bh
return $ IfaceLRCo a b return $ IfaceNthCo a b
13-> do a <- get bh 13-> do a <- get bh
b <- get bh b <- get bh
return $ IfaceInstCo a b return $ IfaceLRCo a b
14-> do a <- get bh 14-> do a <- get bh
b <- get bh b <- get bh
return $ IfaceCoherenceCo a b return $ IfaceInstCo a b
15-> do a <- get bh 15-> do a <- get bh
return $ IfaceKindCo a return $ IfaceKindCo a
16-> do a <- get bh 16-> do a <- get bh
......
...@@ -1199,7 +1199,11 @@ tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) ...@@ -1199,7 +1199,11 @@ tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
tcIfaceCo :: IfaceCoercion -> IfL Coercion tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo = go tcIfaceCo = go
where where
go (IfaceReflCo r t) = Refl r <$> tcIfaceType t go_mco IfaceMRefl = pure MRefl
go_mco (IfaceMCo co) = MCo <$> (go co)
go (IfaceReflCo t) = Refl <$> tcIfaceType t
go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco
go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
go (IfaceTyConAppCo r tc cs) go (IfaceTyConAppCo r tc cs)
= TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
...@@ -1219,8 +1223,6 @@ tcIfaceCo = go ...@@ -1219,8 +1223,6 @@ tcIfaceCo = go
go (IfaceNthCo d c) = do { c' <- go c go (IfaceNthCo d c) = do { c' <- go c
; return $ mkNthCo (nthCoRole d c') d c' } ; return $ mkNthCo (nthCoRole d c') d c' }
go (IfaceLRCo lr c) = LRCo lr <$> go c go (IfaceLRCo lr c) = LRCo lr <$> go c
go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
<*> go c2
go (IfaceKindCo c) = KindCo <$> go c go (IfaceKindCo c) = KindCo <$> go c
go (IfaceSubCo c) = SubCo <$> go c go (IfaceSubCo c) = SubCo <$> go c
go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
......
...@@ -221,7 +221,11 @@ toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion ...@@ -221,7 +221,11 @@ toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
toIfaceCoercionX fr co toIfaceCoercionX fr co
= go co = go co
where where
go (Refl r ty) = IfaceReflCo r (toIfaceTypeX fr ty) go_mco MRefl = IfaceMRefl
go_mco (MCo co) = IfaceMCo $ go co
go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty)
go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
go (CoVarCo cv) go (CoVarCo cv)
-- See [TcTyVars in IfaceType] in IfaceType -- See [TcTyVars in IfaceType] in IfaceType
| cv `elemVarSet` fr = IfaceFreeCoVar cv | cv `elemVarSet` fr = IfaceFreeCoVar cv
...@@ -234,7 +238,6 @@ toIfaceCoercionX fr co ...@@ -234,7 +238,6 @@ toIfaceCoercionX fr co
go (NthCo _r d co) = IfaceNthCo d (go co) go (NthCo _r d co) = IfaceNthCo d (go co)
go (LRCo lr co) = IfaceLRCo lr (go co) go (LRCo lr co) = IfaceLRCo lr (go co)
go (InstCo co arg) = IfaceInstCo (go co) (go arg) go (InstCo co arg) = IfaceInstCo (go co) (go arg)