Commit 1cd3fa29 authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Marge Bot

Implement a coverage checker for injectivity

This fixes #16512.

There are lots of parts of this patch:

* The main payload is in FamInst. See
Note [Coverage condition for injective type families] there
for the overview. But it doesn't fix the bug.

* We now bump the reduction depth every time we discharge
a CFunEqCan. See Note [Flatten when discharging CFunEqCan]
in TcInteract.

* Exploration of this revealed a new, easy to maintain invariant
for CTyEqCans. See Note [Almost function-free] in TcRnTypes.

* We also realized that type inference for injectivity was a
bit incomplete. This means we exchanged lookupFlattenTyVar for
rewriteTyVar. See Note [rewriteTyVar] in TcFlatten. The new
function is monadic while the previous one was pure, necessitating
some faff in TcInteract. Nothing too bad.

* zonkCt did not maintain invariants on CTyEqCan. It's not worth
the bother doing so, so we just transmute CTyEqCans to
CNonCanonicals.

* The pure unifier was finding the fixpoint of the returned
substitution, even when doing one-way matching (in tcUnifyTysWithTFs).
Fixed now.

Test cases: typecheck/should_fail/T16512{a,b}
parent faa30dcb
......@@ -160,16 +160,14 @@ data Ct
| CTyEqCan { -- tv ~ rhs
-- Invariants:
-- * See Note [Applying the inert substitution] in TcFlatten
-- * See Note [inert_eqs: the inert equalities] in TcSMonad
-- * tv not in tvs(rhs) (occurs check)
-- * If tv is a TauTv, then rhs has no foralls
-- (this avoids substituting a forall for the tyvar in other types)
-- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]
-- * rhs may have at most one top-level cast
-- * rhs (perhaps under the one cast) is not necessarily function-free,
-- but it has no top-level function.
-- E.g. a ~ [F b] is fine
-- but a ~ F b is not
-- * rhs (perhaps under the one cast) is *almost function-free*,
-- See Note [Almost function-free]
-- * If the equality is representational, rhs has no top-level newtype
-- See Note [No top-level newtypes on RHS of representational
-- equalities] in TcCanonical
......@@ -289,6 +287,55 @@ of the rhs. This is necessary because both constraints are used for substitution
during solving. If the kinds differed, then the substitution would take a well-kinded
type to an ill-kinded one.
Note [Almost function-free]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
A type is *almost function-free* if it has no type functions (something that
responds True to isTypeFamilyTyCon), except (possibly)
* under a forall, or
* in a coercion (either in a CastTy or a CercionTy)
The RHS of a CTyEqCan must be almost function-free. This is for two reasons:
1. There cannot be a top-level function. If there were, the equality should
really be a CFunEqCan, not a CTyEqCan.
2. Nested functions aren't too bad, on the other hand. However, consider this
scenario:
type family F a = r | r -> a
[D] F ty1 ~ fsk1
[D] F ty2 ~ fsk2
[D] fsk1 ~ [G Int]
[D] fsk2 ~ [G Bool]
type instance G Int = Char
type instance G Bool = Char
If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 --
good! They don't look equal -- but if we aggressively reduce that G Int and
G Bool they would become equal. The "almost function free" makes sure that
these redexes are exposed.
Note that this equality does *not* depend on casts or coercions, and so
skipping these forms is OK. In addition, the result of a type family cannot
be a polytype, so skipping foralls is OK, too. We skip foralls because we
want the output of the flattener to be almost function-free. See Note
[Flattening under a forall] in TcFlatten.
As I (Richard E) write this, it is unclear if the scenario pictured above
can happen -- I would expect the G Int and G Bool to be reduced. But
perhaps it can arise somehow, and maintaining almost function-free is cheap.
Historical note: CTyEqCans used to require only condition (1) above: that no
type family was at the top of an RHS. But work on #16512 suggested that the
injectivity checks were not complete, and adding the requirement that functions
do not appear even in a nested fashion was easy (it was already true, but
unenforced).
The almost-function-free property is checked by isAlmostFunctionFree in TcType.
The flattener (in TcFlatten) produces types that are almost function-free.
-}
mkNonCanonical :: CtEvidence -> Ct
......@@ -1637,8 +1684,7 @@ equality simplification, and type family reduction. (Why combine these? Because
it's actually quite easy to mistake one for another, in sufficiently involved
scenarios, like ConstraintKinds.)
The flag -fcontext-stack=n (not very well named!) fixes the maximium
level.
The flag -freduction-depth=n fixes the maximium level.
* The counter includes the depth of type class instance declarations. Example:
[W] d{7} : Eq [Int]
......
-- The @FamInst@ type: family instance heads
{-# LANGUAGE CPP, GADTs #-}
{-# LANGUAGE CPP, GADTs, ViewPatterns #-}
module FamInst (
FamInstEnvs, tcGetFamInstEnvs,
......@@ -10,7 +10,7 @@ module FamInst (
newFamInst,
-- * Injectivity
makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes
makeInjectivityErrors
) where
import GhcPrelude
......@@ -36,14 +36,17 @@ import DataCon ( dataConName )
import Maybes
import Type
import TyCoRep
import TyCoFVs
import TcMType
import Name
import Pair
import Panic
import VarSet
import FV
import Bag( Bag, unionBags, unitBag )
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
#include "HsVersions.h"
{- Note [The type family instance consistency story]
......@@ -719,10 +722,11 @@ checkForInjectivityConflicts instEnvs famInst
| isTypeFamilyTyCon tycon
-- type family is injective in at least one argument
, Injective inj <- tyConInjectivityInfo tycon = do
{ let axiom = coAxiomSingleBranch fi_ax
{ dflags <- getDynFlags
; let axiom = coAxiomSingleBranch fi_ax
conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
-- see Note [Verifying injectivity annotation] in FamInstEnv
errs = makeInjectivityErrors fi_ax axiom inj conflicts
errs = makeInjectivityErrors dflags fi_ax axiom inj conflicts
; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs
; return (null errs)
}
......@@ -735,19 +739,21 @@ checkForInjectivityConflicts instEnvs famInst
-- | Build a list of injectivity errors together with their source locations.
makeInjectivityErrors
:: CoAxiom br -- ^ Type family for which we generate errors
:: DynFlags
-> CoAxiom br -- ^ Type family for which we generate errors
-> CoAxBranch -- ^ Currently checked equation (represented by axiom)
-> [Bool] -- ^ Injectivity annotation
-> [CoAxBranch] -- ^ List of injectivity conflicts
-> [(SDoc, SrcSpan)]
makeInjectivityErrors fi_ax axiom inj conflicts
makeInjectivityErrors dflags fi_ax axiom inj conflicts
= ASSERT2( any id inj, text "No injective type variables" )
let lhs = coAxBranchLHS axiom
rhs = coAxBranchRHS axiom
fam_tc = coAxiomTyCon fi_ax
are_conflicts = not $ null conflicts
unused_inj_tvs = unusedInjTvsInRHS fam_tc inj lhs rhs
inj_tvs_unused = not $ and (isEmptyVarSet <$> unused_inj_tvs)
(unused_inj_tvs, unused_vis, undec_inst_flag)
= unusedInjTvsInRHS dflags fam_tc lhs rhs
inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs
tf_headed = isTFHeaded rhs
bare_variables = bareTvInRHSViolated lhs rhs
wrong_bare_rhs = not $ null bare_variables
......@@ -758,81 +764,11 @@ makeInjectivityErrors fi_ax axiom inj conflicts
, coAxBranchSpan (head eqns) )
errorIf p f = if p then [f err_builder axiom] else []
in errorIf are_conflicts (conflictInjInstErr conflicts )
++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)
++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs
unused_vis undec_inst_flag)
++ errorIf tf_headed tfHeadedErr
++ errorIf wrong_bare_rhs (bareVariableInRHSErr bare_variables)
-- | Return a list of type variables that the function is injective in and that
-- do not appear on injective positions in the RHS of a family instance
-- declaration. The returned Pair includes invisible vars followed by visible ones
unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet
-- INVARIANT: [Bool] list contains at least one True value
-- See Note [Verifying injectivity annotation] in FamInstEnv.
-- This function implements check (4) described there.
-- In theory, instead of implementing this whole check in this way, we could
-- attempt to unify equation with itself. We would reject exactly the same
-- equations but this method gives us more precise error messages by returning
-- precise names of variables that are not mentioned in the RHS.
unusedInjTvsInRHS tycon injList lhs rhs =
(`minusVarSet` injRhsVars) <$> injLhsVars
where
inj_pairs :: [(Type, ArgFlag)]
-- All the injective arguments, paired with their visibility
inj_pairs = ASSERT2( injList `equalLength` lhs
, ppr tycon $$ ppr injList $$ ppr lhs )
filterByList injList (lhs `zip` tyConArgFlags tycon lhs)
-- set of type and kind variables in which type family is injective
invis_lhs, vis_lhs :: [Type]
(invis_lhs, vis_lhs) = partitionInvisibles inj_pairs
invis_vars = tyCoVarsOfTypes invis_lhs
Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs
injLhsVars
= Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')
vis_vars
-- set of type variables appearing in the RHS on an injective position.
-- For all returned variables we assume their associated kind variables
-- also appear in the RHS.
injRhsVars = injTyVarsOfType rhs
injTyVarsOfType :: TcTauType -> TcTyVarSet
-- Collect all type variables that are either arguments to a type
-- constructor or to /injective/ type families.
-- Determining the overall type determines thes variables
--
-- E.g. Suppose F is injective in its second arg, but not its first
-- then injVarOfType (Either a (F [b] (a,c))) = {a,c}
-- Determining the overall type determines a,c but not b.
injTyVarsOfType ty
| Just ty' <- coreView ty -- #12430
= injTyVarsOfType ty'
injTyVarsOfType (TyVarTy v)
= unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)
injTyVarsOfType (TyConApp tc tys)
| isTypeFamilyTyCon tc
= case tyConInjectivityInfo tc of
NotInjective -> emptyVarSet
Injective inj -> injTyVarsOfTypes (filterByList inj tys)
| otherwise
= injTyVarsOfTypes tys
injTyVarsOfType (LitTy {})
= emptyVarSet
injTyVarsOfType (FunTy _ arg res)
= injTyVarsOfType arg `unionVarSet` injTyVarsOfType res
injTyVarsOfType (AppTy fun arg)
= injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg
-- No forall types in the RHS of a type family
injTyVarsOfType (CastTy ty _) = injTyVarsOfType ty
injTyVarsOfType (CoercionTy {}) = emptyVarSet
injTyVarsOfType (ForAllTy {}) =
panic "unusedInjTvsInRHS.injTyVarsOfType"
injTyVarsOfTypes :: [Type] -> VarSet
injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys
-- | Is type headed by a type family application?
isTFHeaded :: Type -> Bool
-- See Note [Verifying injectivity annotation], case 3.
......@@ -852,6 +788,163 @@ bareTvInRHSViolated pats rhs | isTyVarTy rhs
= filter (not . isTyVarTy) pats
bareTvInRHSViolated _ _ = []
------------------------------------------------------------------
-- Checking for the coverage condition for injective type families
------------------------------------------------------------------
{-
Note [Coverage condition for injective type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Injective Type Families paper describes how we can tell whether
or not a type family equation upholds the injectivity condition.
Briefly, consider the following:
type family F a b = r | r -> a -- NB: b is not injective
type instance F ty1 ty2 = ty3
We need to make sure that all variables mentioned in ty1 are mentioned in ty3
-- that's how we know that knowing ty3 determines ty1. But they can't be
mentioned just anywhere in ty3: they must be in *injective* positions in ty3.
For example:
type instance F a Int = Maybe (G a)
This is no good, if G is not injective. However, if G is indeed injective,
then this would appear to meet our needs. There is a trap here, though: while
knowing G a does indeed determine a, trying to compute a from G a might not
terminate. This is precisely the same problem that we have with functional
dependencies and their liberal coverage condition. Here is the test case:
type family G a = r | r -> a
type instance G [a] = [G a]
[W] G alpha ~ [alpha]
We see that the equation given applies, because G alpha equals a list. So we
learn that alpha must be [beta] for some beta. We then have
[W] G [beta] ~ [[beta]]
This can reduce to
[W] [G beta] ~ [[beta]]
which then decomposes to
[W] G beta ~ [beta]
right where we started. The equation G [a] = [G a] thus is dangerous: while
it does not violate the injectivity assumption, it might throw us into a loop,
with a particularly dastardly Wanted.
We thus do what functional dependencies do: require -XUndecidableInstances to
accept this.
Checking the coverage condition is not terribly hard, but we also want to produce
a nice error message. A nice error message has at least two properties:
1. If any of the variables involved are invisible or are used in an invisible context,
we want to print invisible arguments (as -fprint-explicit-kinds does).
2. If we fail to accept the equation because we're worried about non-termination,
we want to suggest UndecidableInstances.
To gather the right information, we can talk about the *usage* of a variable. Every
variable is used either visibly or invisibly, and it is either not used at all,
in a context where acceptance requires UndecidableInstances, or in a context that
does not require UndecidableInstances. If a variable is used both visibly and
invisibly, then we want to remember the fact that it was used invisibly: printing
out invisibles will be helpful for the user to understand what is going on.
If a variable is used where we need -XUndecidableInstances and where we don't,
we can similarly just remember the latter.
We thus define Visibility and NeedsUndecInstFlag below. These enumerations are
*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair
of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a
variable is NotPresent, but this extra slack in the representation causes no
harm.) We finally define VarUsages as a mapping from variables to VarUsage.
Its Monoid instance combines two maps, using the Semigroup instance of VarUsage
to combine elements that are represented in both maps. In this way, we can
compositionally analyze types (and portions thereof).
To do the injectivity check:
1. We build VarUsages that represent the LHS (rather, the portion of the LHS
that is flagged as injective); each usage on the LHS is NotPresent, because we
hvae not yet looked at the RHS.
2. We also build a VarUsage for the RHS, done by injTyVarUsages.
3. We then combine these maps. Now, every variable in the injective components of the LHS
will be mapped to its correct usage (either NotPresent or perhaps needing
-XUndecidableInstances in order to be seen as injective).
4. We look up each var used in an injective argument on the LHS in
the map, making a list of tvs that should be determined by the RHS
but aren't.
5. We then return the set of bad variables, whether any of the bad
ones were used invisibly, and whether any bad ones need -XUndecidableInstances.
If -XUndecidableInstances is enabled, than a var that needs the flag
won't be bad, so it won't appear in this list.
6. We use all this information to produce a nice error message, (a) switching
on -fprint-explicit-kinds if appropriate and (b) telling the user about
-XUndecidableInstances if appropriate.
-}
-- | Return the set of type variables that a type family equation is
-- expected to be injective in but is not. Suppose we have @type family
-- F a b = r | r -> a@. Then any variables that appear free in the first
-- argument to F in an equation must be fixed by that equation's RHS.
-- This function returns all such variables that are not indeed fixed.
-- It also returns whether any of these variables appear invisibly
-- and whether -XUndecidableInstances would help.
-- See Note [Coverage condition for injective type families].
unusedInjTvsInRHS :: DynFlags
-> TyCon -- type family
-> [Type] -- LHS arguments
-> Type -- the RHS
-> ( TyVarSet
, Bool -- True <=> one or more variable is used invisibly
, Bool) -- True <=> suggest -XUndecidableInstances
-- See Note [Verifying injectivity annotation] in FamInstEnv.
-- This function implements check (4) described there, further
-- described in Note [Coverage condition for injective type families].
-- In theory (and modulo the -XUndecidableInstances wrinkle),
-- instead of implementing this whole check in this way, we could
-- attempt to unify equation with itself. We would reject exactly the same
-- equations but this method gives us more precise error messages by returning
-- precise names of variables that are not mentioned in the RHS.
unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =
-- Note [Coverage condition for injective type families], step 5
(bad_vars, any_invisible, suggest_undec)
where
undec_inst = xopt LangExt.UndecidableInstances dflags
inj_lhs = filterByList inj_list lhs
lhs_vars = tyCoVarsOfTypes inj_lhs
rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs
bad_vars = lhs_vars `minusVarSet` rhs_inj_vars
any_bad = not $ isEmptyVarSet bad_vars
invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs]
any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars)
suggest_undec = any_bad &&
not undec_inst &&
(lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))
-- When the type family is not injective in any arguments
unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False)
---------------------------------------
-- Producing injectivity error messages
---------------------------------------
-- | Type of functions that use error message and a list of axioms to build full
-- error message (with a source location) for injective type families.
......@@ -883,26 +976,28 @@ conflictInjInstErr conflictingEqns errorBuilder tyfamEqn
= panic "conflictInjInstErr"
-- | Build error message for equation with injective type variables unused in
-- the RHS.
unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch
-- the RHS. Note [Coverage condition for injective type families], step 6
unusedInjectiveVarsErr :: TyVarSet
-> Bool -- True <=> print invisible arguments
-> Bool -- True <=> suggest -XUndecidableInstances
-> InjErrorBuilder -> CoAxBranch
-> (SDoc, SrcSpan)
unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn
unusedInjectiveVarsErr tvs has_kinds undec_inst errorBuilder tyfamEqn
= let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)
[tyfamEqn]
in (pprWithExplicitKindsWhen has_kinds doc, loc)
where
tvs = invis_vars `unionVarSet` vis_vars
has_types = not $ isEmptyVarSet vis_vars
has_kinds = not $ isEmptyVarSet invis_vars
doc = sep [ what <+> text "variable" <>
pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)
, text "cannot be inferred from the right-hand side." ]
what = case (has_types, has_kinds) of
(True, True) -> text "Type and kind"
(True, False) -> text "Type"
(False, True) -> text "Kind"
(False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs
$$ extra
what | has_kinds = text "Type/kind"
| otherwise = text "Type"
extra | undec_inst = text "Using UndecidableInstances might help"
| otherwise = empty
msg = doc $$ text "In the type family equation:"
-- | Build error message for equation that has a type family call at the top
......
......@@ -29,10 +29,11 @@ import Type
import TcType( transSuperClasses )
import CoAxiom( TypeEqn )
import Unify
import FamInst( injTyVarsOfTypes )
import InstEnv
import VarSet
import VarEnv
import TyCoFVs
import FV
import Outputable
import ErrUtils( Validity(..), allValid )
import SrcLoc
......@@ -550,7 +551,7 @@ oclose preds fixed_tvs
-- closeOverKinds: see Note [Closing over kinds in coverage]
tv_fds :: [(TyCoVarSet,TyCoVarSet)]
tv_fds = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)
tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs)
-- See Note [Care with type functions]
| pred <- preds
, pred' <- pred : transSuperClasses pred
......
......@@ -1302,10 +1302,10 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2
-- to an irreducible constraint; see typecheck/should_compile/T10494
-- See Note [Decomposing equality], note {4}
can_eq_app ev s1 t1 s2 t2
| CtDerived { ctev_loc = loc } <- ev
| CtDerived {} <- ev
= do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
; stopWith ev "Decomposed [D] AppTy" }
| CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev
| CtWanted { ctev_dest = dest } <- ev
= do { co_s <- unifyWanted loc Nominal s1 s2
; let arg_loc
| isNextArgVisible s1 = loc
......@@ -1323,7 +1323,7 @@ can_eq_app ev s1 t1 s2 t2
| s1k `mismatches` s2k
= canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
| CtGiven { ctev_evar = evar } <- ev
= do { let co = mkTcCoVarCo evar
co_s = mkTcLRCo CLeft co
co_t = mkTcLRCo CRight co
......@@ -1335,6 +1335,8 @@ can_eq_app ev s1 t1 s2 t2
; canEqNC evar_s NomEq s1 s2 }
where
loc = ctEvLoc ev
s1k = tcTypeKind s1
s2k = tcTypeKind s2
......@@ -1585,6 +1587,7 @@ constraints: see Note [Instance and Given overlap] in TcInteract.
Conclusion:
* Decompose [W] N s ~R N t iff there no given constraint that could
later solve it.
-}
canDecomposableTyConAppOK :: CtEvidence -> EqRel
......@@ -1848,9 +1851,9 @@ canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs
-> TcType -- lhs: pretty lhs, already flat
-> TcType -> TcType -- rhs: already flat
-> TcS (StopOrContinue Ct)
canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
| k1 `tcEqType` k2
= canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
= canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
-- So the LHS and RHS don't have equal kinds
-- Note [Flattening] in TcFlatten gives us (F2), which says that
......@@ -1889,7 +1892,7 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
(mkTcReflCo role xi1) rhs_co
-- NB: rewriteEqEvidence executes a swap, if any, so we're
-- NotSwapped now.
; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }
; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_xi1 new_rhs ps_rhs }
else
do { let sym_k1_co = mkTcSymCo k1_co -- :: kind(xi1) ~N flat_k1
sym_k2_co = mkTcSymCo k2_co -- :: kind(xi2) ~N flat_k2
......@@ -1905,7 +1908,7 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
-- no longer swapped, due to rewriteEqEvidence
; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1
; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_xi1
new_rhs flat_k2 ps_rhs } }
where
xi1 = mkTyVarTy tv1
......@@ -1969,16 +1972,16 @@ canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
canEqTyVarHomo :: CtEvidence
-> EqRel -> SwapFlag
-> TcTyVar -- lhs: tv1
-> TcType -- pretty lhs
-> TcType -> TcType -- rhs (might not be flat)
-> TcType -- pretty lhs, flat
-> TcType -> TcType -- rhs, flat
-> TcS (StopOrContinue Ct)
canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
| Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _
| Just (tv2, _) <- tcGetCastedTyVar_maybe xi2
, tv1 == tv2
= canEqReflexive ev eq_rel (mkTyVarTy tv1)
-- we don't need to check co because it must be reflexive
| Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
| Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2
, swapOverTyVars tv1 tv2
= do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
-- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
......@@ -1998,11 +2001,11 @@ canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
; dflags <- getDynFlags
; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }
; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) }
canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2
canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2
= do { dflags <- getDynFlags
; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }
; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 }
-- The RHS here is either not a casted tyvar, or it's a tyvar but we want
-- to rewrite the LHS to the RHS (as per swapOverTyVars)
......@@ -2011,7 +2014,7 @@ canEqTyVar2 :: DynFlags
-> EqRel
-> SwapFlag
-> TcTyVar -- lhs = tv, flat
-> TcType -- rhs
-> TcType -- rhs, flat
-> TcS (StopOrContinue Ct)
-- LHS is an inert type variable,
-- and RHS is fully rewritten, but with type synonyms
......@@ -2186,7 +2189,7 @@ However, if we encounter an equality constraint with a type synonym
application on one side and a variable on the other side, we should
NOT (necessarily) expand the type synonym, since for the purpose of
good error messages we want to leave type synonyms unexpanded as much
as possible. Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.
as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar.
-}
......
......@@ -3,6 +3,7 @@
module TcFlatten(
FlattenMode(..),
flatten, flattenKind, flattenArgsNom,
rewriteTyVar,
unflattenWanteds
) where
......@@ -456,7 +457,8 @@ type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list]
data FlattenEnv
= FE { fe_mode :: !FlattenMode
, fe_loc :: !CtLoc -- See Note [Flattener CtLoc]
, fe_loc :: CtLoc -- See Note [Flattener CtLoc]
-- unbanged because it's bogus in rewriteTyVar
, fe_flavour :: !CtFlavour
, fe_eq_rel :: !EqRel -- See Note [Flattener EqRels]
, fe_work :: !FlatWorkListRef }