Commit e3dbb44f authored by Richard Eisenberg's avatar Richard Eisenberg
Browse files

Fix #12919 by making the flattener homegeneous.

This changes a key invariant of the flattener. Previously,
flattening a type meant flattening its kind as well. But now,
flattening is always homogeneous -- that is, the kind of the
flattened type is the same as the kind of the input type.
This is achieved by various wizardry in the TcFlatten.flatten_many
function, as described in Note [flatten_many].

There are several knock-on effects, including some refactoring
in the canonicalizer to take proper advantage of the flattener's
changed behavior. In particular, the tyvar case of can_eq_nc' no
longer needs to take casts into account.

Another effect is that flattening a tyconapp might change it
into a casted tyconapp. This might happen if the result kind
of the tycon contains a variable, and that variable changes
during flattening. Because the flattener is homogeneous, it tacks
on a cast to keep the tyconapp kind the same. However, this
is problematic when flattening CFunEqCans, which need to have
an uncasted tyconapp on the LHS and must remain homogeneous.
The solution is a more involved canCFunEqCan, described in
Note [canCFunEqCan].

This patch fixes #13643 (as tested in typecheck/should_compile/T13643)
and the panic in typecheck/should_compile/T13822 (as reported in #14024).
Actually, there were two bugs in T13822: the first was just some
incorrect logic in tryFill (part of the unflattener) -- also fixed
in this patch -- and the other was the main bug fixed in this ticket.

The changes in this patch exposed a long-standing flaw in OptCoercion,
in that breaking apart an AppCo sometimes has unexpected effects on
kinds. See new Note [EtaAppCo] in OptCoercion, which explains the
problem and fix.

Also here is a reversion of the major change in
09bf135a, affecting ctEvCoercion.
It turns out that making the flattener homogeneous changes the
invariants on the algorithm, making the change in that patch
no longer necessary.

This patch also fixes:
  #14038 (dependent/should_compile/T14038)
  #13910 (dependent/should_compile/T13910)
  #13938 (dependent/should_compile/T13938)
  #14441 (typecheck/should_compile/T14441)
  #14556 (dependent/should_compile/T14556)
  #14720 (dependent/should_compile/T14720)
  #14749 (typecheck/should_compile/T14749)

Sadly, this patch negatively affects performance of type-family-
heavy code. The following patch fixes these performance degradations.
However, the performance fixes are somewhat invasive and so I've
kept them as a separate patch, labeling this one as [skip ci] so
that validation doesn't fail on the performance cases.
parent 97e1f300
This diff is collapsed.
This diff is collapsed.
......@@ -1597,7 +1597,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
; if canSolveByUnification tclvl tv rhs
then do { solveByUnification ev tv rhs
; n_kicked <- kickOutAfterUnification tv
; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) }
; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
else unsolved_inert }
......@@ -1640,10 +1640,6 @@ solveByUnification wd tv xi
; unifyTyVar tv xi
; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }
ppr_kicked :: Int -> SDoc
ppr_kicked 0 = empty
ppr_kicked n = parens (int n <+> text "kicked out")
{- Note [Avoid double unifications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The spontaneous solver has to return a given which mentions the unified unification
......@@ -1961,59 +1957,34 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
-> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
-- See Note [Top-level reductions for type functions]
-- Previously, we flattened the tc_args here, but there's no need to do so.
-- And, if we did, this function would have all the complication of
-- TcCanonical.canCFunEqCan. See Note [canCFunEqCan]
shortCutReduction old_ev fsk ax_co fam_tc tc_args
= ASSERT( ctEvEqRel old_ev == NomEq)
do { (xis, cos) <- flattenManyNom old_ev tc_args
-- ax_co :: F args ~ G tc_args
-- cos :: xis ~ tc_args
-- old_ev :: F args ~ fsk
-- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
; new_ev <- case ctEvFlavour old_ev of
do { new_ev <- case ctEvFlavour old_ev of
Given -> newGivenEvVar deeper_loc
( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
, evCoercion (mkTcTyConAppCo Nominal fam_tc cos
`mkTcTransCo` mkTcSymCo ax_co
`mkTcTransCo` ctEvCoercion old_ev) )
( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
, evCoercion (mkTcSymCo ax_co
`mkTcTransCo` ctEvCoercion old_ev) )
Wanted {} ->
do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
(mkTyConApp fam_tc xis) (mkTyVarTy fsk)
; setWantedEq (ctev_dest old_ev) $
ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal
fam_tc cos)
`mkTcTransCo` new_co
(mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
; return new_ev }
Derived -> pprPanic "shortCutReduction" (ppr old_ev)
; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
, cc_tyargs = xis, cc_fsk = fsk }
, cc_tyargs = tc_args, cc_fsk = fsk }
; updWorkListTcS (extendWorkListFunEq new_ct)
; stopWith old_ev "Fun/Top (shortcut)" }
where
deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
-- (dischargeFmv x fmv co ty)
-- [W] ev :: F tys ~ fmv
-- co :: F tys ~ xi
-- Precondition: fmv is not filled, and fmv `notElem` xi
-- ev is Wanted
--
-- Then set fmv := xi,
-- set ev := co
-- kick out any inert things that are now rewritable
--
-- Does not evaluate 'co' if 'ev' is Derived
dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi
= ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
do { setWantedEvTerm dest (EvExpr (evCoercion co))
; unflattenFmv fmv xi
; n_kicked <- kickOutAfterUnification fmv
; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }
dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev)
{- Note [Top-level reductions for type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c.f. Note [The flattening story] in TcFlatten
......
......@@ -697,9 +697,11 @@ writeMetaTyVarRef tyvar ref ty
= do { meta_details <- readMutVar ref;
-- Zonk kinds to allow the error check to work
; zonked_tv_kind <- zonkTcType tv_kind
; zonked_ty_kind <- zonkTcType ty_kind
; let kind_check_ok = isPredTy tv_kind -- Don't check kinds for updates
-- to coercion variables. Why not??
; zonked_ty <- zonkTcType ty
; let zonked_ty_kind = typeKind zonked_ty -- need to zonk even before typeKind;
-- otherwise, we can panic in piResultTy
kind_check_ok = isPredTy tv_kind -- Don't check kinds for updates
-- to coercion variables. TODO (RAE): Why not?
|| isConstraintKind zonked_tv_kind
|| tcEqKind zonked_ty_kind zonked_tv_kind
-- Hack alert! isConstraintKind: see TcHsType
......@@ -708,7 +710,7 @@ writeMetaTyVarRef tyvar ref ty
kind_msg = hang (text "Ill-kinded update to meta tyvar")
2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
<+> text ":="
<+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) )
<+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
......@@ -726,7 +728,6 @@ writeMetaTyVarRef tyvar ref ty
; writeMutVar ref (Indirect ty) }
where
tv_kind = tyVarKind tyvar
ty_kind = typeKind ty
tv_lvl = tcTyVarLevel tyvar
ty_lvl = tcTypeLevel ty
......
......@@ -2648,15 +2648,6 @@ For Givens we make new EvVars and bind them immediately. Two main reasons:
So a Given has EvVar inside it rather than (as previously) an EvTerm.
Note [Given in ctEvCoercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When retrieving the evidence from a Given equality, we update the type of the EvVar
from the ctev_pred field. In Note [Evidence field of CtEvidence], we claim that
the type of the evidence is never looked at -- but this isn't true in the case of
a coercion that is used in a type. (See the comments in Note [Flattening] in TcFlatten
about the FTRNotFollowed case of flattenTyVar.) So, right here where we are retrieving
the coercion from a Given, we update the type to make sure it's zonked.
-}
-- | A place for type-checking evidence to go after it is generated.
......@@ -2713,11 +2704,9 @@ ctEvExpr :: CtEvidence -> EvExpr
ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) = evCoercion $ ctEvCoercion ev
ctEvExpr ev = evId (ctEvEvId ev)
-- Always returns a coercion whose type is precisely ctev_pred of the CtEvidence.
-- See also Note [Given in ctEvCoercion]
ctEvCoercion :: CtEvidence -> Coercion
ctEvCoercion (CtGiven { ctev_pred = pred_ty, ctev_evar = ev_id })
= mkTcCoVarCo (setVarType ev_id pred_ty) -- See Note [Given in ctEvCoercion]
ctEvCoercion (CtGiven { ctev_evar = ev_id })
= mkTcCoVarCo ev_id
ctEvCoercion (CtWanted { ctev_dest = dest })
| HoleDest hole <- dest
= -- ctEvCoercion is only called on type equalities
......
......@@ -82,6 +82,7 @@ module TcSMonad (
-- The flattening cache
lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems
dischargeFmv, pprKicked,
-- Inert CFunEqCans
updInertFunEqs, findFunEq,
......@@ -1134,8 +1135,78 @@ work?
because even tyvars in the casts and coercions could give
an infinite loop if we don't expose it
* CIrredCan: Yes if the inert set can rewrite the constraint.
We used to think splitting irreds was unnecessary, but
see Note [Splitting Irred WD constraints]
* Others: nothing is gained by splitting.
Note [Splitting Irred WD constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Splitting Irred constraints can make a difference. Here is the
scenario:
a[sk] :: F v -- F is a type family
beta :: alpha
work item: [WD] a ~ beta
This is heterogeneous, so we try flattening the kinds.
co :: F v ~ fmv
[WD] (a |> co) ~ beta
This is still hetero, so we emit a kind equality and make the work item an
inert Irred.
work item: [D] fmv ~ alpha
inert: [WD] (a |> co) ~ beta (CIrredCan)
Can't make progress on the work item. Add to inert set. This kicks out the
old inert, because a [D] can rewrite a [WD].
work item: [WD] (a |> co) ~ beta
inert: [D] fmv ~ alpha (CTyEqCan)
Can't make progress on this work item either (although GHC tries by
decomposing the cast and reflattening... but that doesn't make a difference),
which is still hetero. Emit a new kind equality and add to inert set. But,
critically, we split the Irred.
work list:
[D] fmv ~ alpha (CTyEqCan)
[D] (a |> co) ~ beta (CIrred) -- this one was split off
inert:
[W] (a |> co) ~ beta
[D] fmv ~ alpha
We quickly solve the first work item, as it's the same as an inert.
work item: [D] (a |> co) ~ beta
inert:
[W] (a |> co) ~ beta
[D] fmv ~ alpha
We decompose the cast, yielding
[D] a ~ beta
We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
then rewrites to alpha.
co' :: F v ~ alpha
[D] (a |> co') ~ beta
Now this equality is homo-kinded. So we swizzle it around to
[D] beta ~ (a |> co')
and set beta := a |> co', and go home happy.
If we don't split the Irreds, we loop. This is all dangerously subtle.
This is triggered by test case typecheck/should_compile/SplitWD.
Note [Examples of how Derived shadows helps completeness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #10009, a very nasty example:
......@@ -1298,7 +1369,9 @@ shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
|| anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
-- NB False: do not ignore casts and coercions
-- See Note [Splitting WD constraints]
where
shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
= anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
shouldSplitWD _ _ = False -- No point in splitting otherwise
......@@ -2954,6 +3027,30 @@ demoteUnfilledFmv fmv
do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
; TcM.writeMetaTyVar fmv tv_ty } }
-----------------------------
dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
-- (dischargeFmv x fmv co ty)
-- [W] ev :: F tys ~ fmv
-- co :: F tys ~ xi
-- Precondition: fmv is not filled, and fmv `notElem` xi
-- ev is Wanted
--
-- Then set fmv := xi,
-- set ev := co
-- kick out any inert things that are now rewritable
--
-- Does not evaluate 'co' if 'ev' is Derived
dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi
= ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
do { setWantedEvTerm dest (EvExpr (evCoercion co))
; unflattenFmv fmv xi
; n_kicked <- kickOutAfterUnification fmv
; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev)
pprKicked :: Int -> SDoc
pprKicked 0 = empty
pprKicked n = parens (int n <+> text "kicked out")
{- *********************************************************************
* *
......@@ -3212,4 +3309,3 @@ from which we get the implication
(forall a. t1 ~ t2)
See TcSMonad.deferTcSForAllEq
-}
......@@ -68,7 +68,7 @@ module TcType (
tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
tcRepGetNumAppTys,
tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar,
tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
---------------------------------
......
......@@ -28,7 +28,7 @@ module Coercion (
mkAxInstRHS, mkUnbranchedAxInstRHS,
mkAxInstLHS, mkUnbranchedAxInstLHS,
mkPiCo, mkPiCos, mkCoCast,
mkSymCo, mkTransCo, mkTransAppCo,
mkSymCo, mkTransCo,
mkNthCo, mkLRCo,
mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos,
mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl,
......@@ -48,7 +48,7 @@ module Coercion (
mapStepResult, unwrapNewTypeStepper,
topNormaliseNewType_maybe, topNormaliseTypeX,
decomposeCo, decomposeFunCo, getCoVar_maybe,
decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,
splitTyConAppCo_maybe,
splitAppCo_maybe,
splitFunCo_maybe,
......@@ -79,7 +79,7 @@ module Coercion (
-- ** Lifting
liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
emptyLiftingContext, extendLiftingContext,
emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
liftCoSubstVarBndrCallback, isMappedByLC,
mkSubstLiftingContext, zapLiftingContext,
......@@ -102,7 +102,7 @@ module Coercion (
tidyCo, tidyCos,
-- * Other
promoteCoercion
promoteCoercion, buildCoercion
) where
#include "HsVersions.h"
......@@ -115,6 +115,7 @@ import TyCon
import CoAxiom
import Var
import VarEnv
import VarSet
import Name hiding ( varName )
import Util
import BasicTypes
......@@ -244,6 +245,64 @@ decomposeFunCo co = ASSERT2( all_ok, ppr co )
Pair s1t1 s2t2 = coercionKind co
all_ok = isFunTy s1t1 && isFunTy s2t2
-- | Decompose a function coercion, either a dependent one or a non-dependent one.
-- This is useful when you are trying to build (ty1 |> co) ty2 ty3 ... tyn, but
-- you are pulling the coercions to the right. For example of why you might want
-- to do so, see Note [Respecting definitional equality] in TyCoRep.
-- This might return *fewer* coercions than there are arguments, if the kind provided
-- doesn't have enough binders.
-- The types passed in are the ty2 ... tyn. If the results are (arg_cos, res_co),
-- then you should build
-- @(ty1 (ty2 |> arg_cos1) (ty3 |> arg_cos2) ... (tym |> arg_com)|> res_co) tym+1 ... tyn@.
decomposePiCos :: Kind -- of the function (ty1), used only to tell -> from ∀ from other
-> [Type] -> CoercionN -> ([CoercionN], CoercionN)
decomposePiCos orig_kind orig_args orig_co = go [] orig_subst orig_kind orig_args orig_co
where
orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes (orig_kind : orig_args)
`unionVarSet` tyCoVarsOfCo orig_co
go :: [CoercionN] -- accumulator for argument coercions, reversed
-> TCvSubst -- instantiating substitution
-> Kind -- of the function being applied (unsubsted)
-> [Type] -- arguments to that function
-> CoercionN -- coercion originally applied to the function
-> ([CoercionN], Coercion)
go acc_arg_cos subst ki (ty:tys) co
| Just (kv, inner_ki) <- splitForAllTy_maybe ki
-- know co :: (forall a:s1.t1) ~ (forall b:s2.t2)
-- function :: forall a:s1.t1 (the function is not passed to decomposePiCos)
-- ty :: s2
-- need arg_co :: s2 ~ s1
-- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]
= let arg_co = mkNthCo 0 (mkSymCo co)
res_co = mkInstCo co (mkNomReflCo ty `mkCoherenceLeftCo` arg_co)
subst' = extendTCvSubst subst kv ty
in
go (arg_co : acc_arg_cos) subst' inner_ki tys res_co
| Just (_arg_ki, res_ki) <- splitFunTy_maybe ki
-- know co :: (s1 -> t1) ~ (s2 -> t2)
-- function :: s1 -> t1
-- ty :: s2
-- need arg_co :: s2 ~ s1
-- res_co :: t1 ~ t2
= let (sym_arg_co, res_co) = decomposeFunCo co
arg_co = mkSymCo sym_arg_co
in
go (arg_co : acc_arg_cos) subst res_ki tys res_co
| let substed_ki = substTy subst ki
, isPiTy substed_ki
-- This might happen if we have to substitute in order to see that the kind
-- is a Π-type.
= let subst' = zapTCvSubst subst
in
go acc_arg_cos subst' substed_ki (ty:tys) co
-- tys might not be empty, if the left-hand type of the original coercion
-- didn't have enough binders
go acc_arg_cos _subst _ki _tys co = (reverse acc_arg_cos, co)
-- | Attempts to obtain the type variable underlying a 'Coercion'
getCoVar_maybe :: Coercion -> Maybe CoVar
getCoVar_maybe (CoVarCo cv) = Just cv
......@@ -449,41 +508,6 @@ One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as
appropriate? I (Richard E.) have decided not to do this, because upgrading a
role is bizarre and a caller should have to ask for this behavior explicitly.
Note [mkTransAppCo]
~~~~~~~~~~~~~~~~~~~
Suppose we have
co1 :: a ~R Maybe
co2 :: b ~R Int
and we want
co3 :: a b ~R Maybe Int
This seems sensible enough. But, we can't let (co3 = co1 co2), because
that's ill-roled! Note that mkAppCo requires a *nominal* second coercion.
The way around this is to use transitivity:
co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int
Or, it's possible everything is the other way around:
co1' :: Maybe ~R a
co2' :: Int ~R b
and we want
co3' :: Maybe Int ~R a b
then
co3' = (Maybe co2') ; (co1' <b>_N)
This is exactly what `mkTransAppCo` builds for us. Information for all
the arguments tends to be to hand at call sites, so it's quicker than
using, say, coercionKind.
-}
mkReflCo :: Role -> Type -> Coercion
......@@ -569,68 +593,6 @@ mkAppCos :: Coercion
-> Coercion
mkAppCos co1 cos = foldl mkAppCo co1 cos
-- | Like `mkAppCo`, but allows the second coercion to be other than
-- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent
-- than either r1 or r2.
mkTransAppCo :: Role -- ^ r1
-> Coercion -- ^ co1 :: ty1a ~r1 ty1b
-> Type -- ^ ty1a
-> Type -- ^ ty1b
-> Role -- ^ r2
-> Coercion -- ^ co2 :: ty2a ~r2 ty2b
-> Type -- ^ ty2a
-> Type -- ^ ty2b
-> Role -- ^ r3
-> Coercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b
mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3
-- How incredibly fiddly! Is there a better way??
= case (r1, r2, r3) of
(_, _, Phantom)
-> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b)
where -- ty1a :: k1a -> k2a
-- ty1b :: k1b -> k2b
-- ty2a :: k1a
-- ty2b :: k1b
-- ty1a ty2a :: k2a
-- ty1b ty2b :: k2b
kind_co1 = mkKindCo co1 -- :: k1a -> k2a ~N k1b -> k2b
kind_co = mkNthCo 1 kind_co1 -- :: k2a ~N k2b
(_, _, Nominal)
-> ASSERT( r1 == Nominal && r2 == Nominal )
mkAppCo co1 co2
(Nominal, Nominal, Representational)
-> mkSubCo (mkAppCo co1 co2)
(_, Nominal, Representational)
-> ASSERT( r1 == Representational )
mkAppCo co1 co2
(Nominal, Representational, Representational)
-> go (mkSubCo co1)
(_ , _, Representational)
-> ASSERT( r1 == Representational && r2 == Representational )
go co1
where
go co1_repr
| Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b
, nextRole ty1b == r2
= (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo`
(mkTyConAppCo Representational tc1b
(zipWith mkReflCo (tyConRolesRepresentational tc1b) tys1b
++ [co2]))
| Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a
, nextRole ty1a == r2
= (mkTyConAppCo Representational tc1a
(zipWith mkReflCo (tyConRolesRepresentational tc1a) tys1a
++ [co2]))
`mkTransCo`
(mkAppCo co1_repr (mkNomReflCo ty2b))
| otherwise
= pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b
, ppr r2, ppr co2, ppr ty2a, ppr ty2b
, ppr r3 ])
-- | Make a Coercion from a tyvar, a kind coercion, and a body coercion.
-- The kind of the tyvar should be the left-hand kind of the kind coercion.
mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion
......@@ -1444,10 +1406,20 @@ extendLiftingContext :: LiftingContext -- ^ original LC
-> TyVar -- ^ new variable to map...
-> Coercion -- ^ ...to this lifted version
-> LiftingContext
-- mappings to reflexive coercions are just substitutions
extendLiftingContext (LC subst env) tv (Refl _ ty) = LC (extendTvSubst subst tv ty) env
extendLiftingContext (LC subst env) tv arg
= ASSERT( isTyVar tv )
LC subst (extendVarEnv env tv arg)
-- | Extend a lifting context with a new mapping, and extend the in-scope set
extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC
-> TyVar -- ^ new variable to map...
-> Coercion -- ^ to this coercion
-> LiftingContext
extendLiftingContextAndInScope (LC subst env) tv co
= extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co
-- | Extend a lifting context with existential-variable bindings.
-- This follows the lifting context extension definition in the
-- "FC with Explicit Kind Equality" paper.
......@@ -1880,3 +1852,64 @@ So it's very important to do the substitution simultaneously;
cf Type.piResultTys (which in fact we call here).
-}
-- | Assuming that two types are the same, ignoring coercions, find
-- a nominal coercion between the types. This is useful when optimizing
-- transitivity over coercion applications, where splitting two
-- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion.
buildCoercion :: Type -> Type -> CoercionN
buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
where
go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
| Just ty2' <- coreView ty2 = go ty1 ty2'
go (CastTy ty1 co) ty2
= go ty1 ty2 `mkCoherenceLeftCo` co
go ty1 (CastTy ty2 co)
= go ty1 ty2 `mkCoherenceRightCo` co
go ty1@(TyVarTy tv1) _tyvarty
= ASSERT( case _tyvarty of
{ TyVarTy tv2 -> tv1 == tv2
; _ -> False } )
mkNomReflCo ty1
go (FunTy arg1 res1) (FunTy arg2 res2)
= mkFunCo Nominal (go arg1 arg2) (go res1 res2)
go (TyConApp tc1 args1) (TyConApp tc2 args2)
= ASSERT( tc1 == tc2 )
mkTyConAppCo Nominal tc1 (zipWith go args1 args2)
go (AppTy ty1a ty1b) ty2
| Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2
= mkAppCo (go ty1a ty2a) (go ty1b ty2b)
go ty1 (AppTy ty2a ty2b)
| Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1
= mkAppCo (go ty1a ty2a) (go ty1b ty2b)
go (ForAllTy (TvBndr tv1 _flag1) ty1) (ForAllTy (TvBndr tv2 _flag2) ty2)
= let kind_co = go (tyVarKind tv1) (tyVarKind tv2)
in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
ty2' = substTyWithInScope in_scope [tv2]
[mkTyVarTy tv1 `mkCastTy` kind_co]
ty2
in
mkForAllCo tv1 kind_co (go ty1 ty2')
go ty1@(LitTy lit1) _lit2
= ASSERT( case _lit2 of
{ LitTy lit2 -> lit1 == lit2
; _ -> False } )
mkNomReflCo ty1
go (CoercionTy co1) (CoercionTy co2)
= mkProofIrrelCo Nominal kind_co co1 co2
where
kind_co = go (coercionType co1) (coercionType co2)
go ty1 ty2
= pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2
, ppr ty1, ppr ty2 ])
......@@ -37,6 +37,7 @@ mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion
isReflCo :: Coercion -> Bool
isReflexiveCo :: Coercion -> Bool
decomposePiCos :: Kind -> [Type] -> Coercion -> ([Coercion], Coercion)
coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role)
coVarRole :: CoVar -> Role
......