diff git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index dfebb87..d540272 100644
 a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ 1,2146 +1,2138 @@
{# LANGUAGE CPP #}
module TcCanonical(
canonicalize,
unifyDerived,
makeSuperClasses, maybeSym,
StopOrContinue(..), stopWith, continueWith,
solveCallStack  For TcSimplify
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnTypes
import TcUnify( swapOverTyVars, metaTyVarUpdateOK )
import TcType
import Type
import TcFlatten
import TcSMonad
import TcEvidence
import TcEvTerm
import Class
import TyCon
import TyCoRep  cleverly decomposes types, good for completeness checking
import Coercion
import FamInstEnv ( FamInstEnvs )
import FamInst ( tcTopNormaliseNewTypeTF_maybe )
import Var
import VarEnv( mkInScopeSet )
import Outputable
import DynFlags( DynFlags )
import NameSet
import RdrName
import HsTypes( HsIPName(..) )
import Pair
import Util
import Bag
import MonadUtils
import Control.Monad
import Data.Maybe ( isJust )
import Data.List ( zip4, foldl' )
import BasicTypes
import Data.Bifunctor ( bimap )
{
************************************************************************
* *
* The Canonicaliser *
* *
************************************************************************
Note [Canonicalization]
~~~~~~~~~~~~~~~~~~~~~~~
Canonicalization converts a simple constraint to a canonical form. It is
unary (i.e. treats individual constraints one at a time).
Constraints originating from userwritten code come into being as
CNonCanonicals (except for CHoleCans, arising from holes). We know nothing
about these constraints. So, first:
Classify CNonCanoncal constraints, depending on whether they
are equalities, class predicates, or other.
Then proceed depending on the shape of the constraint. Generally speaking,
each constraint gets flattened and then decomposed into one of several forms
(see type Ct in TcRnTypes).
When an alreadycanonicalized constraint gets kicked out of the inert set,
it must be recanonicalized. But we know a bit about its shape from the
last time through, so we can skip the classification step.
}
 Toplevel canonicalization
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
canonicalize :: Ct > TcS (StopOrContinue Ct)
canonicalize (CNonCanonical { cc_ev = ev })
= {# SCC "canNC" #}
case classifyPredType (ctEvPred ev) of
ClassPred cls tys > do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
canClassNC ev cls tys
EqPred eq_rel ty1 ty2 > do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
canEqNC ev eq_rel ty1 ty2
IrredPred {} > do traceTcS "canEvNC:irred" (ppr (ctEvPred ev))
canIrred ev
canonicalize (CIrredCan { cc_ev = ev })
= canIrred ev
canonicalize (CDictCan { cc_ev = ev, cc_class = cls
, cc_tyargs = xis, cc_pend_sc = pend_sc })
= {# SCC "canClass" #}
canClass ev cls xis pend_sc
canonicalize (CTyEqCan { cc_ev = ev
, cc_tyvar = tv
, cc_rhs = xi
, cc_eq_rel = eq_rel })
= {# SCC "canEqLeafTyVarEq" #}
canEqNC ev eq_rel (mkTyVarTy tv) xi
 NB: Don't use canEqTyVar because that expects flattened types,
 and tv and xi may not be flat w.r.t. an updated inert set
canonicalize (CFunEqCan { cc_ev = ev
, cc_fun = fn
, cc_tyargs = xis1
, cc_fsk = fsk })
= {# SCC "canEqLeafFunEq" #}
canCFunEqCan ev fn xis1 fsk
canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })
= canHole ev hole
{
************************************************************************
* *
* Class Canonicalization
* *
************************************************************************
}
canClassNC :: CtEvidence > Class > [Type] > TcS (StopOrContinue Ct)
 "NC" means "noncanonical"; that is, we have got here
 from a NonCanonical constraint, not from a CDictCan
 Precondition: EvVar is class evidence
canClassNC ev cls tys
 isGiven ev  See Note [Eagerly expand given superclasses]
= do { sc_cts < mkStrictSuperClasses ev cls tys
; emitWork sc_cts
; canClass ev cls tys False }
 isWanted ev
, Just ip_name < isCallStackPred cls tys
, OccurrenceOf func < ctLocOrigin loc
 If we're given a CallStack constraint that arose from a function
 call, we need to push the current callsite onto the stack instead
 of solving it directly from a given.
 See Note [Overview of implicit CallStacks] in TcEvidence
 and Note [Solving CallStack constraints] in TcSMonad
= do {  First we emit a new constraint that will capture the
 given CallStack.
; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
 We change the origin to IPOccOrigin so
 this rule does not fire again.
 See Note [Overview of implicit CallStacks]
; new_ev < newWantedEvVarNC new_loc pred
 Then we solve the wanted by pushing the callsite
 onto the newly emitted CallStack
; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
; canClass new_ev cls tys False }
 otherwise
= canClass ev cls tys (has_scs cls)
where
has_scs cls = not (null (classSCTheta cls))
loc = ctEvLoc ev
pred = ctEvPred ev
solveCallStack :: CtEvidence > EvCallStack > TcS ()
 Also called from TcSimplify when defaulting call stacks
solveCallStack ev ev_cs = do
 We're given ev_cs :: CallStack, but the evidence term should be a
 dictionary, so we have to coerce ev_cs to a dictionary for
 `IP ip CallStack`. See Note [Overview of implicit CallStacks]
cs_tm < evCallStack ev_cs
let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
setWantedEvBind (ctEvEvId ev) (EvExpr ev_tm)
canClass :: CtEvidence
> Class > [Type]
> Bool  True <=> unexplored superclasses
> TcS (StopOrContinue Ct)
 Precondition: EvVar is class evidence
canClass ev cls tys pend_sc
=  all classes do *nominal* matching
ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
do { (xis, cos, _kind_co) < flattenArgsNom ev cls_tc tys
; MASSERT( isTcReflCo _kind_co )
; let co = mkTcTyConAppCo Nominal cls_tc cos
xi = mkClassPred cls xis
mk_ct new_ev = CDictCan { cc_ev = new_ev
, cc_tyargs = xis
, cc_class = cls
, cc_pend_sc = pend_sc }
; mb < rewriteEvidence ev xi co
; traceTcS "canClass" (vcat [ ppr ev
, ppr xi, ppr mb ])
; return (fmap mk_ct mb) }
where
cls_tc = classTyCon cls
{ Note [The superclass story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to add superclass constraints for two reasons:
* For givens [G], they give us a route to proof. E.g.
f :: Ord a => a > Bool
f x = x == x
We get a Wanted (Eq a), which can only be solved from the superclass
of the Given (Ord a).
* For wanteds [W], and deriveds [WD], [D], they may give useful
functional dependencies. E.g.
class C a b  a > b where ...
class C a b => D a b where ...
Now a [W] constraint (D Int beta) has (C Int beta) as a superclass
and that might tell us about beta, via C's fundeps. We can get this
by generating a [D] (C Int beta) constraint. It's derived because
we don't actually have to cough up any evidence for it; it's only there
to generate fundep equalities.
See Note [Why adding superclasses can help].
For these reasons we want to generate superclass constraints for both
Givens and Wanteds. But:
* (Minor) they are often not needed, so generating them aggressively
is a waste of time.
* (Major) if we want recursive superclasses, there would be an infinite
number of them. Here is a reallife example (Trac #10318);
class (Frac (Frac a) ~ Frac a,
Fractional (Frac a),
IntegralDomain (Frac a))
=> IntegralDomain a where
type Frac a :: *
Notice that IntegralDomain has an associated type Frac, and one
of IntegralDomain's superclasses is another IntegralDomain constraint.
So here's the plan:
1. Eagerly generate superclasses for given (but not wanted)
constraints; see Note [Eagerly expand given superclasses].
This is done using mkStrictSuperClasses in canClassNC, when
we take a noncanonical Given constraint and cannonicalise it.
However stop if you encounter the same class twice. That is,
mkStrictSuperClasses expands eagerly, but has a conservative
termination condition: see Note [Expanding superclasses] in TcType.
2. Solve the wanteds as usual, but do no further expansion of
superclasses for canonical CDictCans in solveSimpleGivens or
solveSimpleWanteds; Note [Danger of adding superclasses during solving]
However, /do/ continue to eagerly expand superlasses for new /given/
/noncanonical/ constraints (canClassNC does this). As Trac #12175
showed, a typefamily application can expand to a class constraint,
and we want to see its superclasses for just the same reason as
Note [Eagerly expand given superclasses].
3. If we have any remaining unsolved wanteds
(see Note [When superclasses help] in TcRnTypes)
try harder: take both the Givens and Wanteds, and expand
superclasses again. See the calls to expandSuperClasses in
TcSimplify.simpl_loop and solveWanteds.
This may succeed in generating (a finite number of) extra Givens,
and extra Deriveds. Both may help the proof.
4. Go round to (2) again. This loop (2,3,4) is implemented
in TcSimplify.simpl_loop.
The cc_pend_sc flag in a CDictCan records whether the superclasses of
this constraint have been expanded. Specifically, in Step 3 we only
expand superclasses for constraints with cc_pend_sc set to true (i.e.
isPendingScDict holds).
Why do we do this? Two reasons:
* To avoid repeated work, by repeatedly expanding the superclasses of
same constraint,
* To terminate the above loop, at least in the XNoRecursiveSuperClasses
case. If there are recursive superclasses we could, in principle,
expand forever, always encountering new constraints.
When we take a CNonCanonical or CIrredCan, but end up classifying it
as a CDictCan, we set the cc_pend_sc flag to False.
Note [Superclass loops]
~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
class C a => D a
class D a => C a
Then, when we expand superclasses, we'll get back to the selfsame
predicate, so we have reached a fixpoint in expansion and there is no
point in fruitlessly expanding further. This case just falls out from
our strategy. Consider
f :: C a => a > Bool
f x = x==x
Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses
G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.)
When processing d3 we find a match with d1 in the inert set, and we always
keep the inert item (d1) if possible: see Note [Replacement vs keeping] in
TcInteract. So d3 dies a quick, happy death.
Note [Eagerly expand given superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In step (1) of Note [The superclass story], why do we eagerly expand
Given superclasses by one layer? (By "one layer" we mean expand transitively
until you meet the same class again  the conservative criterion embodied
in expandSuperClasses. So a "layer" might be a whole stack of superclasses.)
We do this eagerly for Givens mainly because of some very obscure
cases like this:
instance Bad a => Eq (T a)
f :: (Ord (T a)) => blah
f x = ....needs Eq (T a), Ord (T a)....
Here if we can't satisfy (Eq (T a)) from the givens we'll use the
instance declaration; but then we are stuck with (Bad a). Sigh.
This is really a case of nonconfluent proofs, but to stop our users
complaining we expand one layer in advance.
Note [Instance and Given overlap] in TcInteract.
We also want to do this if we have
f :: F (T a) => blah
where
type instance F (T a) = Ord (T a)
So we may need to do a little work on the givens to expose the
class that has the superclasses. That's why the superclass
expansion for Givens happens in canClassNC.
Note [Why adding superclasses can help]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Examples of how adding superclasses can help:
 Example 1
class C a b  a > b
Suppose we want to solve
[G] C a b
[W] C a beta
Then adding [D] beta~b will let us solve it.
 Example 2 (similar but using a typeequality superclass)
class (F a ~ b) => C a b
And try to sllve:
[G] C a b
[W] C a beta
Follow the superclass rules to add
[G] F a ~ b
[D] F a ~ beta
Now we get [D] beta ~ b, and can solve that.
 Example (tcfail138)
class L a b  a > b
class (G a, L a b) => C a b
instance C a b' => G (Maybe a)
instance C a b => C (Maybe a) a
instance L (Maybe a) a
When solving the superclasses of the (C (Maybe a) a) instance, we get
[G] C a b, and hance by superclasses, [G] G a, [G] L a b
[W] G (Maybe a)
Use the instance decl to get
[W] C a beta
Generate its derived superclass
[D] L a beta. Now using fundeps, combine with [G] L a b to get
[D] beta ~ b
which is what we want.
Note [Danger of adding superclasses during solving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a serious, but now outdated example, from Trac #4497:
class Num (RealOf t) => Normed t
type family RealOf x
Assume the generated wanted constraint is:
[W] RealOf e ~ e
[W] Normed e
If we were to be adding the superclasses during simplification we'd get:
[W] RealOf e ~ e
[W] Normed e
[D] RealOf e ~ fuv
[D] Num fuv
==>
e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv
While looks exactly like our original constraint. If we add the
superclass of (Normed fuv) again we'd loop. By adding superclasses
definitely only once, during canonicalisation, this situation can't
happen.
Mind you, now that Wanteds cannot rewrite Derived, I think this particular
situation can't happen.
}
makeSuperClasses :: [Ct] > TcS [Ct]
 Returns strict superclasses, transitively, see Note [The superclasses story]
 See Note [The superclass story]
 The loopbreaking here follows Note [Expanding superclasses] in TcType
 Specifically, for an incoming (C t) constraint, we return all of (C t)'s
 superclasses, up to /and including/ the first repetition of C

 Example: class D a => C a
 class C [a] => D a
 makeSuperClasses (C x) will return (D x, C [x])

 NB: the incoming constraints have had their cc_pend_sc flag already
 flipped to False, by isPendingScDict, so we are /obliged/ to at
 least produce the immediate superclasses
makeSuperClasses cts = concatMapM go cts
where
go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
= mkStrictSuperClasses ev cls tys
go ct = pprPanic "makeSuperClasses" (ppr ct)
mkStrictSuperClasses :: CtEvidence > Class > [Type] > TcS [Ct]
 Return constraints for the strict superclasses of (c tys)
mkStrictSuperClasses ev cls tys
= mk_strict_superclasses (unitNameSet (className cls)) ev cls tys
mk_superclasses :: NameSet > CtEvidence > TcS [Ct]
 Return this constraint, plus its superclasses, if any
mk_superclasses rec_clss ev
 ClassPred cls tys < classifyPredType (ctEvPred ev)
= mk_superclasses_of rec_clss ev cls tys
 otherwise  Superclass is not a class predicate
= return [mkNonCanonical ev]
mk_superclasses_of :: NameSet > CtEvidence > Class > [Type] > TcS [Ct]
 Always return this class constraint,
 and expand its superclasses
mk_superclasses_of rec_clss ev cls tys
 loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
; return [this_ct] }  cc_pend_sc of this_ct = True
 otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
, ppr (isCTupleClass cls)
, ppr rec_clss
])
; sc_cts < mk_strict_superclasses rec_clss' ev cls tys
; return (this_ct : sc_cts) }
 cc_pend_sc of this_ct = False
where
cls_nm = className cls
loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
 Tuples never contribute to recursion, and can be nested
rec_clss' = rec_clss `extendNameSet` cls_nm
this_ct = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
, cc_pend_sc = loop_found }
 NB: If there is a loop, we cut off, so we have not
 added the superclasses, hence cc_pend_sc = True
mk_strict_superclasses :: NameSet > CtEvidence > Class > [Type] > TcS [Ct]
 Always return the immediate superclasses of (cls tys);
 and expand their superclasses, provided none of them are in rec_clss
 nor are repeated
mk_strict_superclasses rec_clss ev cls tys
 CtGiven { ctev_evar = evar, ctev_loc = loc } < ev
= do { sc_evs < newGivenEvVars (mk_given_loc loc)
(mkEvScSelectors (evId evar) cls tys)
; concatMapM (mk_superclasses rec_clss) sc_evs }
 all noFreeVarsOfType tys
= return []  Wanteds with no variables yield no deriveds.
 See Note [Improvement from Ground Wanteds]
 otherwise  Wanted/Derived case, just add Derived superclasses
 that can lead to improvement.
= do { let loc = ctEvLoc ev
; sc_evs < mapM (newDerivedNC loc) (immSuperClasses cls tys)
; concatMapM (mk_superclasses rec_clss) sc_evs }
where
size = sizeTypes tys
mk_given_loc loc
 isCTupleClass cls
= loc  For tuple predicates, just take them apart, without
 adding their (large) size into the chain. When we
 get down to a base predicate, we'll include its size.
 Trac #10335
 GivenOrigin skol_info < ctLocOrigin loc
 See Note [Solving superclass constraints] in TcInstDcls
 for explantation of this transformation for givens
= case skol_info of
InstSkol > loc { ctl_origin = GivenOrigin (InstSC size) }
InstSC n > loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }
_ > loc
 otherwise  Probably doesn't happen, since this function
= loc  is only used for Givens, but does no harm
{
************************************************************************
* *
* Irreducibles canonicalization
* *
************************************************************************
}
canIrred :: CtEvidence > TcS (StopOrContinue Ct)
 Precondition: ty not a tuple and no other evidence form
canIrred ev
 EqPred eq_rel ty1 ty2 < classifyPredType pred
=  For insolubles (all of which are equalities, do /not/ flatten the arguments
 In Trac #14350 doing so led entireunnecessary and ridiculously large
 type function expansion. Instead, canEqNC just applies
 the substitution to the predicate, and may do decomposition;
 e.g. a ~ [a], where [G] a ~ [Int], can decompose
canEqNC ev eq_rel ty1 ty2
 otherwise
= do { traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
; (xi,co) < flatten FM_FlattenAll ev pred  co :: xi ~ pred
; rewriteEvidence ev xi co `andWhenContinue` \ new_ev >
do {  Reclassify, in case flattening has improved its shape
; case classifyPredType (ctEvPred new_ev) of
ClassPred cls tys > canClassNC new_ev cls tys
EqPred eq_rel ty1 ty2 > canEqNC new_ev eq_rel ty1 ty2
_ > continueWith $
mkIrredCt new_ev } }
where
pred = ctEvPred ev
canHole :: CtEvidence > Hole > TcS (StopOrContinue Ct)
canHole ev hole
= do { let ty = ctEvPred ev
; (xi,co) < flatten FM_SubstOnly ev ty  co :: xi ~ ty
; rewriteEvidence ev xi co `andWhenContinue` \ new_ev >
do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev
, cc_hole = hole }))
; stopWith new_ev "Emit insoluble hole" } }
{
************************************************************************
* *
* Equalities
* *
************************************************************************
Note [Canonicalising equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In order to canonicalise an equality, we look at the structure of the
two types at hand, looking for similarities. A difficulty is that the
types may look dissimilar before flattening but similar after flattening.
However, we don't just want to jump in and flatten right away, because
this might be wasted effort. So, after looking for similarities and failing,
we flatten and then try again. Of course, we don't want to loop, so we
track whether or not we've already flattened.
It is conceivable to do a better job at tracking whether or not a type
is flattened, but this is left as future work. (Mar '15)
Note [FunTy and decomposing tycon applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.
This means that we may very well have a FunTy containing a type of some unknown
kind. For instance, we may have,
FunTy (a :: k) Int
Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event
that it sees such a type as it cannot determine the RuntimeReps which the (>)
is applied to. Consequently, it is vital that we instead use
tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.
When this happens can_eq_nc' will fail to decompose, zonk, and try again.
Zonking should fill the variable k, meaning that decomposition will succeed the
second time around.
}
canEqNC :: CtEvidence > EqRel > Type > Type > TcS (StopOrContinue Ct)
canEqNC ev eq_rel ty1 ty2
= do { result < zonk_eq_types ty1 ty2
; case result of
Left (Pair ty1' ty2') > can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2
Right ty > canEqReflexive ev eq_rel ty }
can_eq_nc
:: Bool  True => both types are flat
> CtEvidence
> EqRel
> Type > Type  LHS, after and before typesynonym expansion, resp
> Type > Type  RHS, after and before typesynonym expansion, resp
> TcS (StopOrContinue Ct)
can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2
= do { traceTcS "can_eq_nc" $
vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
; rdr_env < getGlobalRdrEnvTcS
; fam_insts < getFamInstEnvs
; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
can_eq_nc'
:: Bool  True => both input types are flattened
> GlobalRdrEnv  needed to see which newtypes are in scope
> FamInstEnvs  needed to unwrap data instances
> CtEvidence
> EqRel
> Type > Type  LHS, after and before typesynonym expansion, resp
> Type > Type  RHS, after and before typesynonym expansion, resp
> TcS (StopOrContinue Ct)
 Expand synonyms first; see Note [Type synonyms and canonicalization]
can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
 Just ty1' < tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2 ps_ty2
 Just ty2' < tcView ty2 = can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2' ps_ty2
 need to check for reflexivity in the ReprEq case.
 See Note [Eager reflexivity check]
 Check only when flat because the zonk_eq_types check in canEqNC takes
 care of the nonflat case.
can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
 ty1 `tcEqType` ty2
= canEqReflexive ev ReprEq ty1
 When working with ReprEq, unwrap newtypes.
can_eq_nc' _flat rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2
 Just stuff1 < tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
= can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _
 Just stuff2 < tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
= can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1
 Then, get rid of casts
can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
= canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
= canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
 NB: pattern match on True: we want only flat types sent to canEqTyVar.
 See also Note [No toplevel newtypes on RHS of representational equalities]
can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
= canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
= canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1

 Otherwise try to decompose

 Literals
can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
 l1 == l2
= do { setEqIfWanted ev (mkReflCo (eqRelRole eq_rel) ty1)
; stopWith ev "Equal LitTy" }
 Try to decompose type constructor applications
 Including FunTy (s > t)
can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _
 See Note [FunTy and decomposing type constructor applications].
 Just (tc1, tys1) < tcRepSplitTyConApp_maybe' ty1
, Just (tc2, tys2) < tcRepSplitTyConApp_maybe' ty2
, not (isTypeFamilyTyCon tc1)
, not (isTypeFamilyTyCon tc2)
= canTyConApp ev eq_rel tc1 tys1 tc2 tys2
can_eq_nc' _flat _rdr_env _envs ev eq_rel
s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
= can_eq_nc_forall ev eq_rel s1 s2
 See Note [Canonicalising type applications] about why we require flat types
can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
 Just (t2, s2) < tcSplitAppTy_maybe ty2
= can_eq_app ev eq_rel t1 s1 t2 s2
can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
 Just (t1, s1) < tcSplitAppTy_maybe ty1
= can_eq_app ev eq_rel t1 s1 t2 s2
 No similarity in type structure detected. Flatten and try again.
can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
= do { (xi1, co1) < flatten FM_FlattenAll ev ps_ty1
; (xi2, co2) < flatten FM_FlattenAll ev ps_ty2
; new_ev < rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
 We've flattened and the types don't match. Give up.
can_eq_nc' True _rdr_env _envs ev _eq_rel _ ps_ty1 _ ps_ty2
= do { traceTcS "can_eq_nc' catchall case" (ppr ps_ty1 $$ ppr ps_ty2)
; canEqHardFailure ev ps_ty1 ps_ty2 }

can_eq_nc_forall :: CtEvidence > EqRel
> Type > Type  LHS and RHS
> TcS (StopOrContinue Ct)
 (forall as. phi1) ~ (forall bs. phi2)
 Check for length match of as, bs
 Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
 But remember also to unify the kinds of as and bs
 (this is the 'go' loop), and actually substitute phi2[as > cos / bs]
 Remember also that we might have forall z (a:z). blah
 so we must proceed one binder at a time (Trac #13879)
can_eq_nc_forall ev eq_rel s1 s2
 CtWanted { ctev_loc = loc, ctev_dest = orig_dest } < ev
= do { let free_tvs = tyCoVarsOfTypes [s1,s2]
(bndrs1, phi1) = tcSplitForAllTyVarBndrs s1
(bndrs2, phi2) = tcSplitForAllTyVarBndrs s2
; if not (equalLength bndrs1 bndrs2)
then do { traceTcS "Forall failure" $
vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
, ppr (map binderArgFlag bndrs1)
, ppr (map binderArgFlag bndrs2) ]
; canEqHardFailure ev s1 s2 }
else
do { traceTcS "Creating implication for polytype equality" $ ppr ev
; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs
; (subst1, skol_tvs) < tcInstSkolTyVarsX empty_subst1 $
binderVars bndrs1
; let skol_info = UnifyForAllSkol phi1
phi1' = substTy subst1 phi1
 Unify the kinds, extend the substitution
go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
= do { let tv2 = binderVar bndr2
; kind_co < unifyWanted loc Nominal
(tyVarKind skol_tv)
(substTy subst (tyVarKind tv2))
; let subst' = extendTvSubst subst tv2
(mkCastTy (mkTyVarTy skol_tv) kind_co)
; co < go skol_tvs subst' bndrs2
; return (mkForAllCo skol_tv kind_co co) }
 Done: unify phi1 ~ phi2
go [] subst bndrs2
= ASSERT( null bndrs2 )
unifyWanted loc (eqRelRole eq_rel)
phi1' (substTy subst phi2)
go _ _ _ = panic "cna_eq_nc_forall"  case (s:ss) []
empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
; all_co < checkConstraintsTcS skol_info skol_tvs $
go skol_tvs empty_subst2 bndrs2
; setWantedEq orig_dest all_co
; stopWith ev "Deferred polytype equality" } }
 otherwise
= do { traceTcS "Omitting decomposition of given polytype equality" $
pprEq s1 s2  See Note [Do not decompose given polytype equalities]
; stopWith ev "Discard given polytype equality" }

  Compare types for equality, while zonking as necessary. Gives up
 as soon as it finds that two types are not equal.
 This is quite handy when some unification has made two
 types in an inert wanted to be equal. We can discover the equality without
 flattening, which is sometimes very expensive (in the case of type functions).
 In particular, this function makes a ~20% improvement in test case
 perf/compiler/T5030.

 Returns either the (partially zonked) types in the case of
 inequality, or the one type in the case of equality. canEqReflexive is
 a good next step in the 'Right' case. Returning 'Left' is always safe.

 NB: This does *not* look through type synonyms. In fact, it treats type
 synonyms as rigid constructors. In the future, it might be convenient
 to look at only those arguments of type synonyms that actually appear
 in the synonym RHS. But we're not there yet.
zonk_eq_types :: TcType > TcType > TcS (Either (Pair TcType) TcType)
zonk_eq_types = go
where
go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2
go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1
 We handle FunTys explicitly here despite the fact that they could also be
 treated as an application. Why? Well, for one it's cheaper to just look
 at two types (the argument and result types) than four (the argument,
 result, and their RuntimeReps). Also, we haven't completely zonked yet,
 so we may run into an unzonked type variable while trying to compute the
 RuntimeReps of the argument and result types. This can be observed in
 testcase tc269.
go ty1 ty2
 Just (arg1, res1) < split1
, Just (arg2, res2) < split2
= do { res_a < go arg1 arg2
; res_b < go res1 res2
; return $ combine_rev mkFunTy res_b res_a
}
 isJust split1  isJust split2
= bale_out ty1 ty2
where
split1 = tcSplitFunTy_maybe ty1
split2 = tcSplitFunTy_maybe ty2
go ty1 ty2
 Just (tc1, tys1) < tcRepSplitTyConApp_maybe ty1
, Just (tc2, tys2) < tcRepSplitTyConApp_maybe ty2
= if tc1 == tc2 && tys1 `equalLength` tys2
 Crucial to check for equallength args, because
 we cannot assume that the two args to 'go' have
 the same kind. E.g go (Proxy * (Maybe Int))
 (Proxy (*>*) Maybe)
 We'll call (go (Maybe Int) Maybe)
 See Trac #13083
then tycon tc1 tys1 tys2
else bale_out ty1 ty2
go ty1 ty2
 Just (ty1a, ty1b) < tcRepSplitAppTy_maybe ty1
, Just (ty2a, ty2b) < tcRepSplitAppTy_maybe ty2
= do { res_a < go ty1a ty2a
; res_b < go ty1b ty2b
; return $ combine_rev mkAppTy res_b res_a }
go ty1@(LitTy lit1) (LitTy lit2)
 lit1 == lit2
= return (Right ty1)
go ty1 ty2 = bale_out ty1 ty2
 We don't handle more complex forms here
bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
tyvar :: SwapFlag > TcTyVar > TcType
> TcS (Either (Pair TcType) TcType)
 Try to do as little as possible, as anything we do here is redundant
 with flattening. In particular, no need to zonk kinds. That's why
 we don't use the alreadydefined zonking functions
tyvar swapped tv ty
= case tcTyVarDetails tv of
MetaTv { mtv_ref = ref }
> do { cts < readTcRef ref
; case cts of
Flexi > give_up
Indirect ty' > do { trace_indirect tv ty'
; unSwap swapped go ty' ty } }
_ > give_up
where
give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
tyvar_tyvar tv1 tv2
 tv1 == tv2 = return (Right (mkTyVarTy tv1))
 otherwise = do { (ty1', progress1) < quick_zonk tv1
; (ty2', progress2) < quick_zonk tv2
; if progress1  progress2
then go ty1' ty2'
else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
trace_indirect tv ty
= traceTcS "Following filled tyvar (zonk_eq_types)"
(ppr tv <+> equals <+> ppr ty)
quick_zonk tv = case tcTyVarDetails tv of
MetaTv { mtv_ref = ref }
> do { cts < readTcRef ref
; case cts of
Flexi > return (TyVarTy tv, False)
Indirect ty' > do { trace_indirect tv ty'
; return (ty', True) } }
_ > return (TyVarTy tv, False)
 This happens for type families, too. But recall that failure
 here just means to try harder, so it's OK if the type function
 isn't injective.
tycon :: TyCon > [TcType] > [TcType]
> TcS (Either (Pair TcType) TcType)
tycon tc tys1 tys2
= do { results < zipWithM go tys1 tys2
; return $ case combine_results results of
Left tys > Left (mkTyConApp tc <$> tys)
Right tys > Right (mkTyConApp tc tys) }
combine_results :: [Either (Pair TcType) TcType]
> Either (Pair [TcType]) [TcType]
combine_results = bimap (fmap reverse) reverse .
foldl' (combine_rev (:)) (Right [])
 combine (in reverse) a new result onto an alreadycombined result
combine_rev :: (a > b > c)
> Either (Pair b) b
> Either (Pair a) a
> Either (Pair c) c
combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list)
combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys)
combine_rev f (Right tys) (Right ty) = Right (f ty tys)
{
Note [Newtypes can blow the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
newtype X = MkX (Int > X)
newtype Y = MkY (Int > Y)
and now wish to prove
[W] X ~R Y
This Wanted will loop, expanding out the newtypes ever deeper looking
for a solid match or a solid discrepancy. Indeed, there is something
appropriate to this looping, because X and Y *do* have the same representation,
in the limit  they're both (Fix ((>) Int)). However, no finitelysized
coercion will ever witness it. This loop won't actually cause GHC to hang,
though, because we check our depth when unwrapping newtypes.
Note [Eager reflexivity check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
newtype X = MkX (Int > X)
and
[W] X ~R X
Naively, we would start unwrapping X and end up in a loop. Instead,
we do this eager reflexivity check. This is necessary only for representational
equality because the flattener technology deals with the similar case
(recursive type families) for nominal equality.
Note that this check does not catch all cases, but it will catch the cases
we're most worried about, types like X above that are actually inhabited.
Here's another place where this reflexivity check is key:
Consider trying to prove (f a) ~R (f a). The AppTys in there can't
be decomposed, because representational equality isn't congruent with respect
to AppTy. So, when canonicalising the equality above, we get stuck and
would normally produce a CIrredCan. However, we really do want to
be able to solve (f a) ~R (f a). So, in the representational case only,
we do a reflexivity check.
(This would be sound in the nominal case, but unnecessary, and I [Richard
E.] am worried that it would slow down the common case.)
}

  We're able to unwrap a newtype. Update the bits accordingly.
can_eq_newtype_nc :: CtEvidence  ^ :: ty1 ~ ty2
> SwapFlag
> TcType  ^ ty1
> ((Bag GlobalRdrElt, TcCoercion), TcType)  ^ :: ty1 ~ ty1'
> TcType  ^ ty2
> TcType  ^ ty2, with type synonyms
> TcS (StopOrContinue Ct)
can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
= do { traceTcS "can_eq_newtype_nc" $
vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]
 check for blowing our stack:
 See Note [Newtypes can blow the stack]
; checkReductionDepth (ctEvLoc ev) ty1
; addUsedGREs (bagToList gres)
 we have actually used the newtype constructor here, so
 make sure we don't warn about importing it!
; new_ev < rewriteEqEvidence ev swapped ty1' ps_ty2
(mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }

 ^ Decompose a type application.
 All input types must be flat. See Note [Canonicalising type applications]
can_eq_app :: CtEvidence  :: s1 t1 ~r s2 t2
> EqRel  r
> Xi > Xi  s1 t1
> Xi > Xi  s2 t2
> TcS (StopOrContinue Ct)
 AppTys only decompose for nominal equality, so this case just leads
 to an irreducible constraint; see typecheck/should_compile/T10494
 See Note [Decomposing equality], note {4}
can_eq_app ev ReprEq _ _ _ _
= do { traceTcS "failing to decompose representational AppTy equality" (ppr ev)
; continueWith (mkIrredCt ev) }
 no need to call canEqFailure, because that flattens, and the
 types involved here are already flat
can_eq_app ev NomEq s1 t1 s2 t2
 CtDerived { ctev_loc = loc } < ev
= do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
; stopWith ev "Decomposed [D] AppTy" }
 CtWanted { ctev_dest = dest, ctev_loc = loc } < ev
= do { co_s < unifyWanted loc Nominal s1 s2
; let arg_loc
 isNextArgVisible s1 = loc
 otherwise = updateCtLocOrigin loc toInvisibleOrigin
; co_t < unifyWanted arg_loc Nominal t1 t2
; let co = mkAppCo co_s co_t
; setWantedEq dest co
; stopWith ev "Decomposed [W] AppTy" }
 If there is a ForAll/(>) mismatch, the use of the Left coercion
 below is illtyped, potentially leading to a panic in splitTyConApp
 Test case: typecheck/should_run/Typeable1
 We could also include this mismatch check above (for W and D), but it's slow
 and we'll get a better error message not doing it
 s1k `mismatches` s2k
= canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
 CtGiven { ctev_evar = evar, ctev_loc = loc } < ev
= do { let co = mkTcCoVarCo evar
co_s = mkTcLRCo CLeft co
co_t = mkTcLRCo CRight co
; evar_s < newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
, evCoercion co_s )
; evar_t < newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
, evCoercion co_t )
; emitWorkNC [evar_t]
; canEqNC evar_s NomEq s1 s2 }
where
s1k = typeKind s1
s2k = typeKind s2
k1 `mismatches` k2
= isForAllTy k1 && not (isForAllTy k2)
 not (isForAllTy k1) && isForAllTy k2

  Break apart an equality over a casted type
 looking like (ty1 > co1) ~ ty2 (modulo a swapflag)
canEqCast :: Bool  are both types flat?
> CtEvidence
> EqRel
> SwapFlag
> TcType > Coercion  LHS (res. RHS), ty1 > co1
> TcType > TcType  RHS (res. LHS), ty2 both normal and pretty
> TcS (StopOrContinue Ct)
canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2
= do { traceTcS "Decomposing cast" (vcat [ ppr ev
, ppr ty1 <+> text ">" <+> ppr co1
, ppr ps_ty2 ])
; new_ev < rewriteEqEvidence ev swapped ty1 ps_ty2
(mkTcReflCo role ty1 `mkTcCoherenceRightCo` co1)
(mkTcReflCo role ps_ty2)
; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
where
role = eqRelRole eq_rel

canTyConApp :: CtEvidence > EqRel
> TyCon > [TcType]
> TyCon > [TcType]
> TcS (StopOrContinue Ct)
 See Note [Decomposing TyConApps]
canTyConApp ev eq_rel tc1 tys1 tc2 tys2
 tc1 == tc2
, tys1 `equalLength` tys2
= do { inerts < getTcSInerts
; if can_decompose inerts
then do { traceTcS "canTyConApp"
(ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2)
; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
; stopWith ev "Decomposed TyConApp" }
else canEqFailure ev eq_rel ty1 ty2 }
 See Note [Skolem abstract data] (at tyConSkolem)
 tyConSkolem tc1  tyConSkolem tc2
= do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
; continueWith (mkIrredCt ev) }
 Fail straight away for better error messages
 See Note [Use canEqFailure in canDecomposableTyConApp]
 eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
isGenerativeTyCon tc2 Representational)
= canEqFailure ev eq_rel ty1 ty2
 otherwise
= canEqHardFailure ev ty1 ty2
where
ty1 = mkTyConApp tc1 tys1
ty2 = mkTyConApp tc2 tys2
loc = ctEvLoc ev
pred = ctEvPred ev
 See Note [Decomposing equality]
can_decompose inerts
= isInjectiveTyCon tc1 (eqRelRole eq_rel)
 (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))
{
Note [Use canEqFailure in canDecomposableTyConApp]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must use canEqFailure, not canEqHardFailure here, because there is
the possibility of success if working with a representational equality.
Here is one case:
type family TF a where TF Char = Bool
data family DF a
newtype instance DF Bool = MkDF Int
Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
know `a`. This is *not* a hard failure, because we might soon learn
that `a` is, in fact, Char, and then the equality succeeds.
Here is another case:
[G] Age ~R Int
where Age's constructor is not in scope. We don't want to report
an "inaccessible code" error in the context of this Given!
For example, see typecheck/should_compile/T10493, repeated here:
import Data.Ord (Down)  no constructor
foo :: Coercible (Down Int) Int => Down Int > Int
foo = coerce
That should compile, but only because we use canEqFailure and not
canEqHardFailure.
Note [Decomposing equality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a constraint (of any flavour and role) that looks like
T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,
of course, is "it depends". This Note spells it all out.
In this Note, "decomposition" refers to taking the constraint
[fl] (T tys1 ~X T tys2)
(for some flavour fl and some role X) and replacing it with
[fls'] (tys1 ~Xs' tys2)
where that notation indicates a list of new constraints, where the
new constraints may have different flavours and different roles.
The key property to consider is injectivity. When decomposing a Given the
decomposition is sound if and only if T is injective in all of its type
arguments. When decomposing a Wanted, the decomposition is sound (assuming the
correct roles in the produced equality constraints), but it may be a guess 
that is, an unforced decision by the constraint solver. Decomposing Wanteds
over injective TyCons does not entail guessing. But sometimes we want to
decompose a Wanted even when the TyCon involved is not injective! (See below.)
So, in broad strokes, we want this rule:
(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective
at role X.
Pursuing the details requires exploring three axes:
* Flavour: Given vs. Derived vs. Wanted
* Role: Nominal vs. Representational
* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable
(So a type variable isn't a TyCon, but it's convenient to put the AppTy case
in the same table.)
Right away, we can say that Derived behaves just as Wanted for the purposes
of decomposition. The difference between Derived and Wanted is the handling of
evidence. Since decomposition in these cases isn't a matter of soundness but of
guessing, we want the same behavior regardless of evidence.
Here is a table (discussion following) detailing where decomposition of
(T s1 ... sn) ~r (T t1 .. tn)
is allowed. The first four lines (Data types ... type family) refer
to TyConApps with various TyCons T; the last line is for AppTy, where
there is presumably a type variable at the head, so it's actually
(s s1 ... sn) ~r (t t1 .. tn)
NOMINAL GIVEN WANTED
Datatype YES YES
Newtype YES YES
Data family YES YES
Type family YES, in injective args{1} YES, in injective args{1}
Type variable YES YES
REPRESENTATIONAL GIVEN WANTED
Datatype YES YES
Newtype NO{2} MAYBE{2}
Data family NO{3} MAYBE{3}
Type family NO NO
Type variable NO{4} NO{4}
{1}: Type families can be injective in some, but not all, of their arguments,
so we want to do partial decomposition. This is quite different than the way
other decomposition is done, where the decomposed equalities replace the original
one. We thus proceed much like we do with superclasses: emitting new Givens
when "decomposing" a partiallyinjective type family Given and new Deriveds
when "decomposing" a partiallyinjective type family Wanted. (As of the time of
writing, 13 June 2015, the implementation of injective type families has not
been merged, but it should be soon. Please delete this parenthetical if the
implementation is indeed merged.)
{2}: See Note [Decomposing newtypes at representational role]
{3}: Because of the possibility of newtype instances, we must treat
data families like newtypes. See also Note [Decomposing newtypes at
representational role]. See #10534 and test case
typecheck/should_fail/T10534.
{4}: Because type variables can stand in for newtypes, we conservatively do not
decompose AppTys over representational equality.
In the implementation of can_eq_nc and friends, we don't directly pattern
match using lines like in the tables above, as those tables don't cover
all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,
boiling the tables above down to rule (*). The exceptions to rule (*) are for
injective type families, which are handled separately from other decompositions,
and the MAYBE entries above.
Note [Decomposing newtypes at representational role]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This note discusses the 'newtype' line in the REPRESENTATIONAL table
in Note [Decomposing equality]. (At nominal role, newtypes are fully
decomposable.)
Here is a representative example of why representational equality over
newtypes is tricky:
newtype Nt a = Mk Bool  NB: a is not used in the RHS,
type role Nt representational  but the user gives it an R role anyway
If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to
[W] alpha ~R beta, because it's possible that alpha and beta aren't
representationally equal. Here's another example.
newtype Nt a = MkNt (Id a)
type family Id a where Id a = a
[W] Nt Int ~R Nt Age
Because of its use of a type family, Nt's parameter will get inferred to have
a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which
is unsatisfiable. Unwrapping, though, leads to a solution.
Conclusion:
* Unwrap newtypes before attempting to decompose them.
This is done in can_eq_nc'.
It all comes from the fact that newtypes aren't necessarily injective
w.r.t. representational equality.
Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use
NthCo on representational coercions over newtypes. NthCo comes into play
only when decomposing givens.
Conclusion:
* Do not decompose [G] N s ~R N t
Is it sensible to decompose *Wanted* constraints over newtypes? Yes!
It's the only way we could ever prove (IO Int ~R IO Age), recalling
that IO is a newtype.
However we must be careful. Consider
type role Nt representational
[G] Nt a ~R Nt b (1)
[W] NT alpha ~R Nt b (2)
[W] alpha ~ a (3)
If we focus on (3) first, we'll substitute in (2), and now it's
identical to the given (1), so we succeed. But if we focus on (2)
first, and decompose it, we'll get (alpha ~R b), which is not soluble.
This is exactly like the question of overlapping Givens for class
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
> TyCon > [TcType] > [TcType]
> TcS ()
 Precondition: tys1 and tys2 are the same length, hence "OK"
canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
= case ev of
CtDerived {}
> unifyDeriveds loc tc_roles tys1 tys2
CtWanted { ctev_dest = dest }
> do { cos < zipWith4M unifyWanted new_locs tc_roles tys1 tys2
; setWantedEq dest (mkTyConAppCo role tc cos) }
CtGiven { ctev_evar = evar }
> do { let ev_co = mkCoVarCo evar
; given_evs < newGivenEvVars loc $
[ ( mkPrimEqPredRole r ty1 ty2
, evCoercion $ mkNthCo r i ev_co )
 (r, ty1, ty2, i) < zip4 tc_roles tys1 tys2 [0..]
, r /= Phantom
, not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
; emitWorkNC given_evs }
where
loc = ctEvLoc ev
role = eqRelRole eq_rel
tc_roles = tyConRolesX role tc
 the following makes a better distinction between "kind" and "type"
 in error messages
bndrs = tyConBinders tc
is_kinds = map isNamedTyConBinder bndrs
is_viss = map isVisibleTyConBinder bndrs
kind_xforms = map (\is_kind > if is_kind then toKindLoc else id) is_kinds
vis_xforms = map (\is_vis > if is_vis then id
else flip updateCtLocOrigin toInvisibleOrigin)
is_viss
 zipWith3 (.) composes its first two arguments and applies it to the third
new_locs = zipWith3 (.) kind_xforms vis_xforms (repeat loc)
  Call when canonicalizing an equality fails, but if the equality is
 representational, there is some hope for the future.
 Examples in Note [Use canEqFailure in canDecomposableTyConApp]
canEqFailure :: CtEvidence > EqRel
> TcType > TcType > TcS (StopOrContinue Ct)
canEqFailure ev NomEq ty1 ty2
= canEqHardFailure ev ty1 ty2
canEqFailure ev ReprEq ty1 ty2
= do { (xi1, co1) < flatten FM_FlattenAll ev ty1
; (xi2, co2) < flatten FM_FlattenAll ev ty2
 We must flatten the types before putting them in the
 inert set, so that we are sure to kick them out when
 new equalities become available
; traceTcS "canEqFailure with ReprEq" $
vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]
; new_ev < rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
; continueWith (mkIrredCt new_ev) }
  Call when canonicalizing an equality fails with utterly no hope.
canEqHardFailure :: CtEvidence
> TcType > TcType > TcS (StopOrContinue Ct)
 See Note [Make sure that insolubles are fully rewritten]
canEqHardFailure ev ty1 ty2
= do { (s1, co1) < flatten FM_SubstOnly ev ty1
; (s2, co2) < flatten FM_SubstOnly ev ty2
; new_ev < rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
; continueWith (mkInsolubleCt new_ev) }
{
Note [Decomposing TyConApps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
(s1 ~ s2, t1 ~ t2)
and push those back into the work list. But if
s1 = K k1 s2 = K k2
then we will just decomopose s1~s2, and it might be better to
do so on the spot. An important special case is where s1=s2,
and we get just Refl.
So canDecomposableTyCon is a fastpath decomposition that uses
unifyWanted etc to shortcut that work.
Note [Canonicalising type applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given (s1 t1) ~ ty2, how should we proceed?
The simple things is to see if ty2 is of form (s2 t2), and
decompose. By this time s1 and s2 can't be saturated type
function applications, because those have been dealt with
by an earlier equation in can_eq_nc, so it is always sound to
decompose.
However, overeager decomposition gives bad error messages
for things like
a b ~ Maybe c
e f ~ p > q
Suppose (in the first example) we already know a~Array. Then if we
decompose the application eagerly, yielding
a ~ Maybe
b ~ c
we get an error "Can't match Array ~ Maybe",
but we'd prefer to get "Can't match Array b ~ Maybe c".
So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of
replacing (a b) by (Array b), before using try_decompose_app to
decompose it.
Note [Make sure that insolubles are fully rewritten]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When an equality fails, we still want to rewrite the equality
all the way down, so that it accurately reflects
(a) the mutable reference substitution in force at start of solving
(b) any tybinds in force at this point in solving
See Note [Rewrite insolubles] in TcSMonad.
And if we don't do this there is a bad danger that
TcSimplify.applyTyVarDefaulting will find a variable
that has in fact been substituted.
Note [Do not decompose Given polytype equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this?
No  what would the evidence look like? So instead we simply discard
this given evidence.
Note [Combining insoluble constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As this point we have an insoluble constraint, like Int~Bool.
* If it is Wanted, delete it from the cache, so that subsequent
Int~Bool constraints give rise to separate error messages
* But if it is Derived, DO NOT delete from cache. A class constraint
may get kicked out of the inert set, and then have its functional
dependency Derived constraints generated a second time. In that
case we don't want to get two (or more) error messages by
generating two (or more) insoluble fundep constraints from the same
class constraint.
Note [No toplevel newtypes on RHS of representational equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we're in this situation:
work item: [W] c1 : a ~R b
inert: [G] c2 : b ~R Id a
where
newtype Id a = Id a
We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened
and the Id newtype is unwrapped. This is assured by requiring only flat
types in canEqTyVar *and* having the newtypeunwrapping check above
the tyvar check in can_eq_nc.
Note [Occurs check error]
~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an occurs check error, are we necessarily hosed? Say our
tyvar is tv1 and the type it appears in is xi2. Because xi2 is function
free, then if we're computing w.r.t. nominal equality, then, yes, we're
hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.
representational equality, this is a little subtler. Once again, (a ~R [a])
is a bad thing, but (a ~R N a) for a newtype N might be just fine. This
means also that (a ~ b a) might be fine, because `b` might become a newtype.
So, we must check: does tv1 appear in xi2 under any type constructor
that is generative w.r.t. representational equality? That's what
isInsolubleOccursCheck does.
See also #10715, which induced this addition.
Note [canCFunEqCan]
~~~~~~~~~~~~~~~~~~~
Flattening the arguments to a type family can change the kind of the type
family application. As an easy example, consider (Any k) where (k ~ Type)
is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
The problem here is that the fsk in the CFunEqCan will have the old kind.
The solution is to come up with a new fsk/fmv of the right kind. For
givens, this is easy: just introduce a new fsk and update the flatcache
with the new one. For wanteds, we want to solve the old one if favor of
the new one, so we use dischargeFmv. This also kicks out constraints
from the inert set; this behavior is correct, as the kindchange may
allow more constraints to be solved.
}
canCFunEqCan :: CtEvidence
> TyCon > [TcType]  LHS
> TcTyVar  RHS
> TcS (StopOrContinue Ct)
 ^ Canonicalise a CFunEqCan. We know that
 the arg types are already flat,
 and the RHS is a fsk, which we must *not* substitute.
 So just substitute in the LHS
canCFunEqCan ev fn tys fsk
= do { (tys', cos, kind_co) < flattenArgsNom ev fn tys
 cos :: tys' ~ tys
; let lhs_co = mkTcTyConAppCo Nominal fn cos
 :: F tys' ~ F tys
new_lhs = mkTyConApp fn tys'
flav = ctEvFlavour ev
; (ev', fsk')
 See Note [canCFunEqCan]
< if isTcReflCo kind_co
then do { let fsk_ty = mkTyVarTy fsk
; ev' < rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
lhs_co (mkTcNomReflCo fsk_ty)
; return (ev', fsk) }
else do { (ev', new_co, new_fsk)
< newFlattenSkolem flav (ctEvLoc ev) fn tys'
 ; case flav of
 Given > return ()  nothing more to do.
  NB: new_co is stored within ev',
  and will be put in the flat_cache below
 _ > do { let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
  sym lhs_co :: F tys ~ F tys'
  new_co :: F tys' ~ new_fsk
  co :: F tys ~ (new_fsk > kind_co)
 co = mkTcSymCo lhs_co `mkTcTransCo`
 (new_co `mkTcCoherenceRightCo` kind_co)

 ; traceTcS "Discharging fmv due to hetero flattening" empty
 ; dischargeFmv ev fsk co xi }
+ ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
+  sym lhs_co :: F tys ~ F tys'
+  new_co :: F tys' ~ new_fsk
+  co :: F tys ~ (new_fsk > kind_co)
+ co = mkTcSymCo lhs_co `mkTcTransCo`
+ (new_co `mkTcCoherenceRightCo` kind_co)
+
+ ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
+ ; dischargeFunEq ev fsk co xi
; return (ev', new_fsk) }
; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
, cc_tyargs = tys', cc_fsk = fsk' }) }

canEqTyVar :: CtEvidence  ev :: lhs ~ rhs
> EqRel > SwapFlag
> TcTyVar  tv1
> 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
 k1 `tcEqType` k2
= canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
 Note [Flattening] in TcFlatten gives us (F2), which says that
 flattening is always homogeneous (doesn't change kinds). But
 perhaps by flattening the kinds of the two sides of the equality
 at hand makes them equal. So let's try that.
 otherwise
= do { (flat_k1, k1_co) < flattenKind loc flav k1  k1_co :: flat_k1 ~N kind(xi1)
; (flat_k2, k2_co) < flattenKind loc flav k2  k2_co :: flat_k2 ~N kind(xi2)
; traceTcS "canEqTyVar tried flattening kinds"
(vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)
, text "~"
, parens (ppr xi2 <+> dcolon <+> ppr k2) ]
, ppr flat_k1
, ppr k1_co
, ppr flat_k2
, ppr k2_co ])
 we know the LHS is a tyvar. So let's dump all the coercions on the RHS
 If flat_k1 == flat_k2, let's dump all the coercions on the RHS and
 then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
 (as an optimization, so that we don't have to flatten the kinds again)
 and then emit a kind equality in canEqTyVarHetero.
 See Note [Equalities with incompatible kinds]
; let role = eqRelRole eq_rel
; if flat_k1 `tcEqType` flat_k2
then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co
 :: kind(xi2) ~N kind(xi1)
new_rhs = xi2 `mkCastTy` rhs_kind_co
ps_rhs = ps_xi2 `mkCastTy` rhs_kind_co
rhs_co = mkTcReflCo role xi2 `mkTcCoherenceLeftCo` rhs_kind_co
; new_ev < rewriteEqEvidence ev swapped xi1 new_rhs
(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 }
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
new_lhs = xi1 `mkCastTy` sym_k1_co  :: flat_k1
new_rhs = xi2 `mkCastTy` sym_k2_co  :: flat_k2
ps_rhs = ps_xi2 `mkCastTy` sym_k2_co
lhs_co = mkReflCo role xi1 `mkTcCoherenceLeftCo` sym_k1_co
rhs_co = mkReflCo role xi2 `mkTcCoherenceLeftCo` sym_k2_co
 lhs_co :: (xi1 > sym k1_co) ~ xi1
 rhs_co :: (xi2 > sym k2_co) ~ 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
new_rhs flat_k2 ps_rhs } }
where
xi1 = mkTyVarTy tv1
k1 = tyVarKind tv1
k2 = typeKind xi2
loc = ctEvLoc ev
flav = ctEvFlavour ev
canEqTyVarHetero :: CtEvidence  :: (tv1 > co1 :: ki1) ~ (xi2 :: ki2)
> EqRel
> TcTyVar > TcCoercionN > TcKind  tv1 > co1 :: ki1
> TcType  pretty tv1 (*without* the coercion)
> TcType > TcKind  xi2 :: ki2
> TcType  pretty xi2
> TcS (StopOrContinue Ct)
canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
 See Note [Equalities with incompatible kinds]
 CtGiven { ctev_evar = evar } < ev
 unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)
 swapped : tm :: (rhs :: ki2) ~ (lhs :: ki1)
 = do { kind_ev_id < newBoundEvVarId kind_pty
 (evCoercion $ mkTcKindCo $ mkTcCoVarCo evar)
  kind_ev_id :: (ki1 :: *) ~ (ki2 :: *) (whether swapped or not)
 ; let kind_ev = CtGiven { ctev_pred = kind_pty
 , ctev_evar = kind_ev_id
 , ctev_loc = kind_loc }
+ = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)
+ ; kind_ev < newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
+ ; let  kind_ev :: (ki1 :: *) ~ (ki2 :: *) (whether swapped or not)
 co1 :: kind(tv1) ~N ki1
 homo_co :: ki2 ~N kind(tv1)
 homo_co = mkTcSymCo (mkCoVarCo kind_ev_id) `mkTcTransCo` mkTcSymCo co1

+ homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1
rhs' = mkCastTy xi2 homo_co  :: kind(tv1)
ps_rhs' = mkCastTy ps_xi2 homo_co  :: kind(tv1)
rhs_co = mkReflCo role xi2 `mkTcCoherenceLeftCo` homo_co
 rhs_co :: (xi2 > homo_co :: kind(tv1)) ~ xi2
lhs' = mkTyVarTy tv1  :: kind(tv1)
lhs_co = mkReflCo role lhs' `mkTcCoherenceRightCo` co1
 lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 > co1 :: ki1)
; traceTcS "Hetero equality gives rise to given kind equality"
 (ppr kind_ev_id <+> dcolon <+> ppr kind_pty)
+ (ppr kind_ev <+> dcolon <+> ppr kind_pty)
; emitWorkNC [kind_ev]
; type_ev < rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co
; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
 See Note [Equalities with incompatible kinds]
 otherwise  Wanted and Derived
 NB: all kind equalities are Nominal
= do { emitNewDerivedEq kind_loc Nominal ki1 ki2
 kind_ev :: (ki1 :: *) ~ (ki2 :: *)
; traceTcS "Hetero equality gives rise to derived kind equality" $
ppr ev
; continueWith (mkIrredCt ev) }
where
kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc
loc = ctev_loc ev
role = eqRelRole eq_rel
 guaranteed that typeKind lhs == typeKind rhs
canEqTyVarHomo :: CtEvidence
> EqRel > SwapFlag
> TcTyVar  lhs: tv1
> TcType  pretty lhs
> TcType > TcType  rhs (might not be flat)
> TcS (StopOrContinue Ct)
canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
 Just (tv2, _) < tcGetCastedTyVar_maybe ty2
, 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
, swapOverTyVars tv1 tv2
= do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
 FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
 let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
 Flatten the RHS less vigorously, to avoid gratuitous flattening
 True <=> xi2 should not itself be a typefunction application
; let role = eqRelRole eq_rel
sym_co2 = mkTcSymCo co2
ty1 = mkTyVarTy tv1
new_lhs = ty1 `mkCastTy` sym_co2
lhs_co = mkReflCo role ty1 `mkTcCoherenceLeftCo` sym_co2
new_rhs = mkTyVarTy tv2
rhs_co = mkReflCo role new_rhs `mkTcCoherenceRightCo` co2
; 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) }
canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2
= do { dflags < getDynFlags
; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }
 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)
canEqTyVar2 :: DynFlags
> CtEvidence  lhs ~ rhs (or, if swapped, orhs ~ olhs)
> EqRel
> SwapFlag
> TcTyVar  lhs = tv, flat
> TcType  rhs
> TcS (StopOrContinue Ct)
 LHS is an inert type variable,
 and RHS is fully rewritten, but with type synonyms
 preserved as much as possible
canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
 Just rhs' < metaTyVarUpdateOK dflags tv1 rhs  No occurs check
 Must do the occurs check even on tyvar/tyvar
 equalities, in case have x ~ (y :: ..x...)
 Trac #12593
= do { new_ev < rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
, cc_rhs = rhs', cc_eq_rel = eq_rel }) }
 otherwise  For some reason (occurs check, or forall) we can't unify
 We must not use it for further rewriting!
= do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
; new_ev < rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
; if isInsolubleOccursCheck eq_rel tv1 rhs
then continueWith (mkInsolubleCt new_ev)
 If we have a ~ [a], it is not canonical, and in particular
 we don't want to rewrite existing inerts with it, otherwise
 we'd risk divergence in the constraint solver
else continueWith (mkIrredCt new_ev) }
 A representational equality with an occurscheck problem isn't
 insoluble! For example:
 a ~R b a
 We might learn that b is the newtype Id.
 But, the occurscheck certainly prevents the equality from being
 canonical, and we might loop if we were to use it in rewriting.
where
role = eqRelRole eq_rel
lhs = mkTyVarTy tv1
rewrite_co1 = mkTcReflCo role lhs
rewrite_co2 = mkTcReflCo role rhs
  Solve a reflexive equality constraint
canEqReflexive :: CtEvidence  ty ~ ty
> EqRel
> TcType  ty
> TcS (StopOrContinue Ct)  always Stop
canEqReflexive ev eq_rel ty
= do { setEvBindIfWanted ev (evCoercion $
mkTcReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" }
{
Note [Canonical orientation for tyvar/tyvar equality constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we have a ~ b where both 'a' and 'b' are TcTyVars, which way
round should be oriented in the CTyEqCan? The rules, implemented by
canEqTyVarTyVar, are these
* If either is a flattenmetavariables, it goes on the left.
* Put a metatyvar on the left if possible
alpha[3] ~ r
* If both are metatyvars, put the more touchable one (deepest level
number) on the left, so there is the best chance of unifying it
alpha[3] ~ beta[2]
* If both are metatyvars and both at the same level, put a SigTv
on the right if possible
alpha[2] ~ beta[2](sigtv)
That way, when we unify alpha := beta, we don't lose the SigTv flag.
* Put a metatv with a System Name on the left if possible so it
gets eliminated (improves error messages)
* If one is a flattenskolem, put it on the left so that it is
substituted out Note [Elminate flatskols]
fsk ~ a
Note [Equalities with incompatible kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What do we do when we have an equality
(tv :: k1) ~ (rhs :: k2)
where k1 and k2 differ? This Note explores this treacherous area.
First off, the question above is slightly the wrong question. Flattening
a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening
the kind might introduce a cast. So we might have a casted tyvar on the
left. We thus revise our test case to
(tv > co :: k1) ~ (rhs :: k2)
We must proceed differently here depending on whether we have a Wanted
or a Given. Consider this:
[W] w :: (alpha :: k) ~ (Int :: Type)
where k is a skolem. One possible way forward is this:
[W] co :: k ~ Type
[W] w :: (alpha :: k) ~ (Int > sym co :: k)
The next step will be to unify
alpha := Int > sym co
Now, consider what error we'll report if we can't solve the "co"
wanted. Its CtOrigin is the w wanted... which now reads (after zonking)
Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which
is embarrassing. See #11198 for more tales of destruction.
The reason for this odd behavior is much the same as
Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the
new `co` is a Wanted.
The solution is then not to use `co` to "rewrite"  that is, cast
 `w`, but instead to keep `w` heterogeneous and
irreducible. Given that we're not using `co`, there is no reason to
collect evidence for it, so `co` is born a Derived, with a CtOrigin
of KindEqOrigin.
When the Derived is solved (by unification), the original wanted (`w`)
will get kicked out.
Note that, if we had [G] co1 :: k ~ Type available, then none of this code would
trigger, because flattening would have rewritten k to Type. That is,
`w` would look like [W] (alpha > co1 :: Type) ~ (Int :: Type), and the tyvar
case will trigger, correctly rewriting alpha to (Int > sym co1).
Successive canonicalizations of the same Wanted may produce
duplicate Deriveds. Similar duplications can happen with fundeps, and there
seems to be no easy way to avoid. I expect this case to be rare.
For Givens, this problem doesn't bite, so a heterogeneous Given gives
rise to a Given kind equality. No Deriveds here. We thus homogenise
the Given (see the "homo_co" in the Given case in canEqTyVar) and
carry on with a homogeneous equality constraint.
Separately, I (Richard E) spent some time pondering what to do in the case
that we have [W] (tv > co1 :: k1) ~ (tv > co2 :: k2) where k1 and k2
differ. Note that the tv is the same. (This case is handled as the first
case in canEqTyVarHomo.) At one point, I thought we could solve this limited
form of heterogeneous Wanted, but I then reconsidered and now treat this case
just like any other heterogeneous Wanted.
Note [Type synonyms and canonicalization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We treat type synonym applications as xi types, that is, they do not
count as type function applications. However, we do need to be a bit
careful with type synonyms: like type functions they may not be
generative or injective. However, unlike type functions, they are
parametric, so there is no problem in expanding them whenever we see
them, since we do not need to know anything about their arguments in
order to expand them; this is what justifies not having to treat them
as specially as type function applications. The thing that causes
some subtleties is that we prefer to leave type synonym applications
*unexpanded* whenever possible, in order to generate better error
messages.
If we encounter an equality constraint with type synonym applications
on both sides, or a type synonym application on one side and some sort
of type application on the other, we simply must expand out the type
synonyms in order to continue decomposing the equality constraint into
primitive equality constraints. For example, suppose we have
type F a = [Int]
and we encounter the equality
F a ~ [b]
In order to continue we must expand F a into [Int], giving us the
equality
[Int] ~ [b]
which we can then decompose into the more primitive equality
constraint
Int ~ b.
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.
}
{
************************************************************************
* *
Evidence transformation
* *
************************************************************************
}
data StopOrContinue a
= ContinueWith a  The constraint was not solved, although it may have
 been rewritten
 Stop CtEvidence  The (rewritten) constraint was solved
SDoc  Tells how it was solved
 Any new subgoals have been put on the work list
instance Functor StopOrContinue where
fmap f (ContinueWith x) = ContinueWith (f x)
fmap _ (Stop ev s) = Stop ev s
instance Outputable a => Outputable (StopOrContinue a) where
ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev
ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
continueWith :: a > TcS (StopOrContinue a)
continueWith = return . ContinueWith
stopWith :: CtEvidence > String > TcS (StopOrContinue a)
stopWith ev s = return (Stop ev (text s))
andWhenContinue :: TcS (StopOrContinue a)
> (a > TcS (StopOrContinue b))
> TcS (StopOrContinue b)
andWhenContinue tcs1 tcs2
= do { r < tcs1
; case r of
Stop ev s > return (Stop ev s)
ContinueWith ct > tcs2 ct }
infixr 0 `andWhenContinue`  allow chaining with ($)
rewriteEvidence :: CtEvidence  old evidence
> TcPredType  new predicate
> TcCoercion  Of type :: new predicate ~
> TcS (StopOrContinue CtEvidence)
 Returns Just new_ev iff either (i) 'co' is reflexivity
 or (ii) 'co' is not reflexivity, and 'new_pred' not cached
 In either case, there is nothing new to do with new_ev
{
rewriteEvidence old_ev new_pred co
Main purpose: create new evidence for new_pred;
unless new_pred is cached already
* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev
* If old_ev was wanted, create a binding for old_ev, in terms of new_ev
* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev
* Returns Nothing if new_ev is already cached
Old evidence New predicate is Return new evidence
flavour of same flavor

Wanted Already solved or in inert Nothing
or Derived Not Just new_evidence
Given Already in inert Nothing
Not Just new_evidence
Note [Rewriting with Refl]
~~~~~~~~~~~~~~~~~~~~~~~~~~
If the coercion is just reflexivity then you may reuse the same
variable. But be careful! Although the coercion is Refl, new_pred
may reflect the result of unification alpha := ty, so new_pred might
not _look_ the same as old_pred, and it's vital to proceed from now on
using new_pred.
qThe flattener preserves type synonyms, so they should appear in new_pred
as well as in old_pred; that is important for good error messages.
}
rewriteEvidence old_ev@(CtDerived {}) new_pred _co
=  If derived, don't even look at the coercion.
 This is very important, DO NOT reorder the equations for
 rewriteEvidence to put the isTcReflCo test first!
 Why? Because for *Derived* constraints, c, the coercion, which
 was produced by flattening, may contain suspended calls to
 (ctEvExpr c), which fails for Derived constraints.
 (Getting this wrong caused Trac #7384.)
continueWith (old_ev { ctev_pred = new_pred })
rewriteEvidence old_ev new_pred co
 isTcReflCo co  See Note [Rewriting with Refl]
= continueWith (old_ev { ctev_pred = new_pred })
rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
= do { new_ev < newGivenEvVar loc (new_pred, new_tm)
; continueWith new_ev }
where
 mkEvCast optimises ReflCo
new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
(ctEvRole ev)
(mkTcSymCo co))
rewriteEvidence ev@(CtWanted { ctev_dest = dest
, ctev_loc = loc }) new_pred co
= do { mb_new_ev < newWanted loc new_pred
; MASSERT( tcCoercionRole co == ctEvRole ev )
; setWantedEvTerm dest
(EvExpr $ mkEvCast (getEvExpr mb_new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
; case mb_new_ev of
Fresh new_ev > continueWith new_ev
Cached _ > stopWith ev "Cached wanted" }
rewriteEqEvidence :: CtEvidence  Old evidence :: olhs ~ orhs (not swapped)
 or orhs ~ olhs (swapped)
> SwapFlag
> TcType > TcType  New predicate nlhs ~ nrhs
 Should be zonked, because we use typeKind on nlhs/nrhs
> TcCoercion  lhs_co, of type :: nlhs ~ olhs
> TcCoercion  rhs_co, of type :: nrhs ~ orhs
> TcS CtEvidence  Of type nlhs ~ nrhs
 For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)
 we generate
 If not swapped
 g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co
 If 'swapped'
 g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co

 For (Wanted w) we do the dual thing.
 New w1 : nlhs ~ nrhs
 If not swapped
 w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co
 If swapped
 w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co

 It's all a form of rewwriteEvidence, specialised for equalities
rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
 CtDerived {} < old_ev  Don't force the evidence for a Derived
= return (old_ev { ctev_pred = new_pred })
 NotSwapped < swapped
, isTcReflCo lhs_co  See Note [Rewriting with Refl]
, isTcReflCo rhs_co
= return (old_ev { ctev_pred = new_pred })
 CtGiven { ctev_evar = old_evar } < old_ev
= do { let new_tm = evCoercion (lhs_co
`mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
`mkTcTransCo` mkTcSymCo rhs_co)
; newGivenEvVar loc' (new_pred, new_tm) }
 CtWanted { ctev_dest = dest } < old_ev
= do { (new_ev, hole_co) < newWantedEq loc' (ctEvRole old_ev) nlhs nrhs
; let co = maybeSym swapped $
mkSymCo lhs_co
`mkTransCo` hole_co
`mkTransCo` rhs_co
; setWantedEq dest co
; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
; return new_ev }
 otherwise
= panic "rewriteEvidence"
where
new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
 equality is like a type class. Bumping the depth is necessary because
 of recursive newtypes, where "reducing" a newtype can actually make
 it bigger. See Note [Newtypes can blow the stack].
loc = ctEvLoc old_ev
loc' = bumpCtLocDepth loc
{ Note [unifyWanted and unifyDerived]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When decomposing equalities we often create new wanted constraints for
(s ~ t). But what if s=t? Then it'd be faster to return Refl right away.
Similar remarks apply for Derived.
Rather than making an equality test (which traverses the structure of the
type, perhaps fruitlessly), unifyWanted traverses the common structure, and
bales out when it finds a difference by creating a new Wanted constraint.
But where it succeeds in finding common structure, it just builds a coercion
to reflect it.
}
unifyWanted :: CtLoc > Role
> TcType > TcType > TcS Coercion
 Return coercion witnessing the equality of the two types,
 emitting new work equalities where necessary to achieve that
 Very good shortcut when the two types are equal, or nearly so
 See Note [unifyWanted and unifyDerived]
 The returned coercion's role matches the input parameter
unifyWanted loc Phantom ty1 ty2
= do { kind_co < unifyWanted loc Nominal (typeKind ty1) (typeKind ty2)
; return (mkPhantomCo kind_co ty1 ty2) }
unifyWanted loc role orig_ty1 orig_ty2
= go orig_ty1 orig_ty2
where
go ty1 ty2  Just ty1' < tcView ty1 = go ty1' ty2
go ty1 ty2  Just ty2' < tcView ty2 = go ty1 ty2'
go (FunTy s1 t1) (FunTy s2 t2)
= do { co_s < unifyWanted loc role s1 s2
; co_t < unifyWanted loc role t1 t2
; return (mkFunCo role co_s co_t) }
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
 tc1 == tc2, tys1 `equalLength` tys2
, isInjectiveTyCon tc1 role  don't look under newtypes at Rep equality
= do { cos < zipWith3M (unifyWanted loc)
(tyConRolesX role tc1) tys1 tys2
; return (mkTyConAppCo role tc1 cos) }
go ty1@(TyVarTy tv) ty2
= do { mb_ty < isFilledMetaTyVar_maybe tv
; case mb_ty of
Just ty1' > go ty1' ty2
Nothing > bale_out ty1 ty2}
go ty1 ty2@(TyVarTy tv)
= do { mb_ty < isFilledMetaTyVar_maybe tv
; case mb_ty of
Just ty2' > go ty1 ty2'
Nothing > bale_out ty1 ty2 }
go ty1@(CoercionTy {}) (CoercionTy {})
= return (mkReflCo role ty1)  we just don't care about coercions!
go ty1 ty2 = bale_out ty1 ty2
bale_out ty1 ty2
 ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)
 Check for equality; e.g. a ~ a, or (m a) ~ (m a)
 otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2
unifyDeriveds :: CtLoc > [Role] > [TcType] > [TcType] > TcS ()
 See Note [unifyWanted and unifyDerived]
unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2
unifyDerived :: CtLoc > Role > Pair TcType > TcS ()
 See Note [unifyWanted and unifyDerived]
unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2
unify_derived :: CtLoc > Role > TcType > TcType > TcS ()
 Create new Derived and put it in the work list
 Should do nothing if the two types are equal
 See Note [unifyWanted and unifyDerived]
unify_derived _ Phantom _ _ = return ()
unify_derived loc role orig_ty1 orig_ty2
= go orig_ty1 orig_ty2
where
go ty1 ty2  Just ty1' < tcView ty1 = go ty1' ty2
go ty1 ty2  Just ty2' < tcView ty2 = go ty1 ty2'
go (FunTy s1 t1) (FunTy s2 t2)
= do { unify_derived loc role s1 s2
; unify_derived loc role t1 t2 }
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
 tc1 == tc2, tys1 `equalLength` tys2
, isInjectiveTyCon tc1 role
= unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2
go ty1@(TyVarTy tv) ty2
= do { mb_ty < isFilledMetaTyVar_maybe tv
; case mb_ty of
Just ty1' > go ty1' ty2
Nothing > bale_out ty1 ty2 }
go ty1 ty2@(TyVarTy tv)
= do { mb_ty < isFilledMetaTyVar_maybe tv
; case mb_ty of
Just ty2' > go ty1 ty2'
Nothing > bale_out ty1 ty2 }
go ty1 ty2 = bale_out ty1 ty2
bale_out ty1 ty2
 ty1 `tcEqType` ty2 = return ()
 Check for equality; e.g. a ~ a, or (m a) ~ (m a)
 otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2
maybeSym :: SwapFlag > TcCoercion > TcCoercion
maybeSym IsSwapped co = mkTcSymCo co
maybeSym NotSwapped co = co
diff git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 09cfd15..b2be509 100644
 a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ 1,2980 +1,2953 @@
{# LANGUAGE CPP #}
module TcInteract (
solveSimpleGivens,  Solves [Ct]
solveSimpleWanteds,  Solves Cts
) where
#include "HsVersions.h"
import GhcPrelude
import BasicTypes ( SwapFlag(..), isSwapped,
infinity, IntWithInf, intGtLimit )
import TcCanonical
import TcFlatten
import TcUnify( canSolveByUnification )
import VarSet
import Type
import Kind( isConstraintKind )
import InstEnv( DFunInstType, lookupInstEnv
, instanceDFunId, isOverlappable )
import CoAxiom( sfInteractTop, sfInteractInert )
import TcMType (newMetaTyVars)
import Var
import TcType
import Name
import RdrName ( lookupGRE_FieldLabel )
import PrelNames ( knownNatClassName, knownSymbolClassName,
typeableClassName,
coercibleTyConKey,
hasFieldClassName,
heqTyConKey, eqTyConKey, ipClassKey )
import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
coercibleDataCon, constraintKindTyCon )
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import Id( idType, isNaughtyRecordSelector )
import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
import Class
import TyCon
import DataCon( dataConWrapId )
import FieldLabel
import FunDeps
import FamInst
import FamInstEnv
import Unify ( tcUnifyTyWithTFs )
import TcEvidence
import MkCore ( mkStringExprFS, mkNaturalExpr )
import Outputable
import TcRnTypes
import TcSMonad
import Bag
import MonadUtils ( concatMapM, foldlM )
import Data.List( partition, foldl', deleteFirstsBy )
import SrcLoc
import VarEnv
import Control.Monad
import Maybes( isJust )
import Pair (Pair(..))
import Unique( hasKey )
import DynFlags
import Util
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
{
**********************************************************************
* *
* Main Interaction Solver *
* *
**********************************************************************
Note [Basic Simplifier Plan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1. Pick an element from the WorkList if there exists one with depth
less than our contextstack depth.
2. Run it down the 'stage' pipeline. Stages are:
 canonicalization
 inert reactions
 spontaneous reactions
 toplevel intreactions
Each stage returns a StopOrContinue and may have sideffected
the inerts or worklist.
The threading of the stages is as follows:
 If (Stop) is returned by a stage then we start again from Step 1.
 If (ContinueWith ct) is returned by a stage, we feed 'ct' on to
the next stage in the pipeline.
4. If the element has survived (i.e. ContinueWith x) the last stage
then we add him in the inerts and jump back to Step 1.
If in Step 1 no such element exists, we have exceeded our contextstack
depth and will simply fail.
Note [Unflatten after solving the simple wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We unflatten after solving the wc_simples of an implication, and before attempting
to float. This means that
* The fsk/fmv flattenskolems only survive during solveSimples. We don't
need to worry about them across successive passes over the constraint tree.
(E.g. we don't need the old ic_fsk field of an implication.
* When floating an equality outwards, we don't need to worry about floating its
associated flattening constraints.
* Another tricky case becomes easy: Trac #4935
type instance F True a b = a
type instance F False a b = b
[w] F c a b ~ gamma
(c ~ True) => a ~ gamma
(c ~ False) => b ~ gamma
Obviously this is soluble with gamma := F c a b, and unflattening
will do exactly that after solving the simple constraints and before
attempting the implications. Before, when we were not unflattening,
we had to push Wanted funeqs in as new givens. Yuk!
Another example that becomes easy: indexed_types/should_fail/T7786
[W] BuriedUnder sub k Empty ~ fsk
[W] Intersect fsk inv ~ s
[w] xxx[1] ~ s
[W] forall[2] . (xxx[1] ~ Empty)
=> Intersect (BuriedUnder sub k Empty) inv ~ Empty
Note [Running plugins on unflattened wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is an annoying mismatch between solveSimpleGivens and
solveSimpleWanteds, because the latter needs to fiddle with the inert
set, unflatten and zonk the wanteds. It passes the zonked wanteds
to runTcPluginsWanteds, which produces a replacement set of wanteds,
some additional insolubles and a flag indicating whether to go round
the loop again. If so, prepareInertsForImplications is used to remove
the previous wanteds (which will still be in the inert set). Note
that prepareInertsForImplications will discard the insolubles, so we
must keep track of them separately.
}
solveSimpleGivens :: [Ct] > TcS ()
solveSimpleGivens givens
 null givens  Shortcut for common case
= return ()
 otherwise
= do { traceTcS "solveSimpleGivens {" (ppr givens)
; go givens
; traceTcS "End solveSimpleGivens }" empty }
where
go givens = do { solveSimples (listToBag givens)
; new_givens < runTcPluginsGiven
; when (notNull new_givens) $
go new_givens }
solveSimpleWanteds :: Cts > TcS WantedConstraints
 NB: 'simples' may contain /derived/ equalities, floated
 out from a nested implication. So don't discard deriveds!
 The result is not necessarily zonked
solveSimpleWanteds simples
= do { traceTcS "solveSimpleWanteds {" (ppr simples)
; dflags < getDynFlags
; (n,wc) < go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })
; traceTcS "solveSimpleWanteds end }" $
vcat [ text "iterations =" <+> ppr n
, text "residual =" <+> ppr wc ]
; return wc }
where
go :: Int > IntWithInf > WantedConstraints > TcS (Int, WantedConstraints)
go n limit wc
 n `intGtLimit` limit
= failTcS (hang (text "solveSimpleWanteds: too many iterations"
<+> parens (text "limit =" <+> ppr limit))
2 (vcat [ text "Set limit with fconstraintsolveriterations=n; n=0 for no limit"
, text "Simples =" <+> ppr simples
, text "WC =" <+> ppr wc ]))
 isEmptyBag (wc_simple wc)
= return (n,wc)
 otherwise
= do {  Solve
(unif_count, wc1) < solve_simple_wanteds wc
 Run plugins
; (rerun_plugin, wc2) < runTcPluginsWanted wc1
 See Note [Running plugins on unflattened wanteds]
; if unif_count == 0 && not rerun_plugin
then return (n, wc2)  Done
else do { traceTcS "solveSimple going round again:" $
ppr unif_count $$ ppr rerun_plugin
; go (n+1) limit wc2 } }  Loop
solve_simple_wanteds :: WantedConstraints > TcS (Int, WantedConstraints)
 Try solving these constraints
 Affects the unification state (of course) but not the inert set
 The result is not necessarily zonked
solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 })
= nestTcS $
do { solveSimples simples1
; (implics2, tv_eqs, fun_eqs, others) < getUnsolvedInerts
; (unif_count, unflattened_eqs) < reportUnifications $
unflattenWanteds tv_eqs fun_eqs
 See Note [Unflatten after solving the simple wanteds]
; return ( unif_count
, WC { wc_simple = others `andCts` unflattened_eqs
, wc_impl = implics1 `unionBags` implics2 }) }
{ Note [The solveSimpleWanteds loop]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Solving a bunch of simple constraints is done in a loop,
(the 'go' loop of 'solveSimpleWanteds'):
1. Try to solve them; unflattening may lead to improvement that
was not exploitable during solving
2. Try the plugin
3. If step 1 did improvement during unflattening; or if the plugin
wants to run again, go back to step 1
Nonobviously, improvement can also take place during
the unflattening that takes place in step (1). See TcFlatten,
See Note [Unflattening can force the solver to iterate]
}
 The main solver loop implements Note [Basic Simplifier Plan]

solveSimples :: Cts > TcS ()
 Returns the final InertSet in TcS
 Has no effect on worklist or residualimplications
 The constraints are initially examined in lefttoright order
solveSimples cts
= {# SCC "solveSimples" #}
do { updWorkListTcS (\wl > foldrBag extendWorkListCt wl cts)
; solve_loop }
where
solve_loop
= {# SCC "solve_loop" #}
do { sel < selectNextWorkItem
; case sel of
Nothing > return ()
Just ct > do { runSolverPipeline thePipeline ct
; solve_loop } }
  Extract the (inert) givens and invoke the plugins on them.
 Remove solved givens from the inert set and emit insolubles, but
 return new work produced so that 'solveSimpleGivens' can feed it back
 into the main solver.
runTcPluginsGiven :: TcS [Ct]
runTcPluginsGiven
= do { plugins < getTcPlugins
; if null plugins then return [] else
do { givens < getInertGivens
; if null givens then return [] else
do { p < runTcPlugins plugins (givens,[],[])
; let (solved_givens, _, _) = pluginSolvedCts p
insols = pluginBadCts p
; updInertCans (removeInertCts solved_givens)
; updInertIrreds (\irreds > extendCtsList irreds insols)
; return (pluginNewCts p) } } }
  Given a bag of (flattened, zonked) wanteds, invoke the plugins on
 them and produce an updated bag of wanteds (possibly with some new
 work) and a bag of insolubles. The boolean indicates whether
 'solveSimpleWanteds' should feed the updated wanteds back into the
 main solver.
runTcPluginsWanted :: WantedConstraints > TcS (Bool, WantedConstraints)
runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 })
 isEmptyBag simples1
= return (False, wc)
 otherwise
= do { plugins < getTcPlugins
; if null plugins then return (False, wc) else
do { given < getInertGivens
; simples1 < zonkSimples simples1  Plugin requires zonked inputs
; let (wanted, derived) = partition isWantedCt (bagToList simples1)
; p < runTcPlugins plugins (given, derived, wanted)
; let (_, _, solved_wanted) = pluginSolvedCts p
(_, unsolved_derived, unsolved_wanted) = pluginInputCts p
new_wanted = pluginNewCts p
insols = pluginBadCts p
 SLPJ: I'm deeply suspicious of this
 ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)
; mapM_ setEv solved_wanted
; return ( notNull (pluginNewCts p)
, WC { wc_simple = listToBag new_wanted `andCts`
listToBag unsolved_wanted `andCts`
listToBag unsolved_derived `andCts`
listToBag insols
, wc_impl = implics1 } ) } }
where
setEv :: (EvTerm,Ct) > TcS ()
setEv (ev,ct) = case ctEvidence ct of
CtWanted { ctev_dest = dest } > setWantedEvTerm dest ev
_ > panic "runTcPluginsWanted.setEv: attempt to solve nonwanted!"
  A triple of (given, derived, wanted) constraints to pass to plugins
type SplitCts = ([Ct], [Ct], [Ct])
  A solved triple of constraints, with evidence for wanteds
type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])
  Represents collections of constraints generated by typechecker
 plugins
data TcPluginProgress = TcPluginProgress
{ pluginInputCts :: SplitCts
 ^ Original inputs to the plugins with solved/bad constraints
 removed, but otherwise unmodified
, pluginSolvedCts :: SolvedCts
 ^ Constraints solved by plugins
, pluginBadCts :: [Ct]
 ^ Constraints reported as insoluble by plugins
, pluginNewCts :: [Ct]
 ^ New constraints emitted by plugins
}
getTcPlugins :: TcS [TcPluginSolver]
getTcPlugins = do { tcg_env < getGblEnv; return (tcg_tc_plugins tcg_env) }
  Starting from a triple of (given, derived, wanted) constraints,
 invoke each of the typechecker plugins in turn and return

 * the remaining unmodified constraints,
 * constraints that have been solved,
 * constraints that are insoluble, and
 * new work.

 Note that new work generated by one plugin will not be seen by
 other plugins on this pass (but the main constraint solver will be
 reinvoked and they will see it later). There is no check that new
 work differs from the original constraints supplied to the plugin:
 the plugin itself should perform this check if necessary.
runTcPlugins :: [TcPluginSolver] > SplitCts > TcS TcPluginProgress
runTcPlugins plugins all_cts
= foldM do_plugin initialProgress plugins
where
do_plugin :: TcPluginProgress > TcPluginSolver > TcS TcPluginProgress
do_plugin p solver = do
result < runTcPluginTcS (uncurry3 solver (pluginInputCts p))
return $ progress p result
progress :: TcPluginProgress > TcPluginResult > TcPluginProgress
progress p (TcPluginContradiction bad_cts) =
p { pluginInputCts = discard bad_cts (pluginInputCts p)
, pluginBadCts = bad_cts ++ pluginBadCts p
}
progress p (TcPluginOk solved_cts new_cts) =
p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p)
, pluginSolvedCts = add solved_cts (pluginSolvedCts p)
, pluginNewCts = new_cts ++ pluginNewCts p
}
initialProgress = TcPluginProgress all_cts ([], [], []) [] []
discard :: [Ct] > SplitCts > SplitCts
discard cts (xs, ys, zs) =
(xs `without` cts, ys `without` cts, zs `without` cts)
without :: [Ct] > [Ct] > [Ct]
without = deleteFirstsBy eqCt
eqCt :: Ct > Ct > Bool
eqCt c c' = ctFlavour c == ctFlavour c'
&& ctPred c `tcEqType` ctPred c'
add :: [(EvTerm,Ct)] > SolvedCts > SolvedCts
add xs scs = foldl' addOne scs xs
addOne :: SolvedCts > (EvTerm,Ct) > SolvedCts
addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of
CtGiven {} > (ct:givens, deriveds, wanteds)
CtDerived{} > (givens, ct:deriveds, wanteds)
CtWanted {} > (givens, deriveds, (ev,ct):wanteds)
type WorkItem = Ct
type SimplifierStage = WorkItem > TcS (StopOrContinue Ct)
runSolverPipeline :: [(String,SimplifierStage)]  The pipeline
> WorkItem  The work item
> TcS ()
 Run this item down the pipeline, leaving behind new work and inerts
runSolverPipeline pipeline workItem
= do { wl < getWorkList
; inerts < getTcSInerts
; tclevel < getTcLevel
; traceTcS " " empty
; traceTcS "Start solver pipeline {" $
vcat [ text "tclevel =" <+> ppr tclevel
, text "work item =" <+> ppr workItem
, text "inerts =" <+> ppr inerts
, text "rest of worklist =" <+> ppr wl ]
; bumpStepCountTcS  One step for each constraint processed
; final_res < run_pipeline pipeline (ContinueWith workItem)
; case final_res of
Stop ev s > do { traceFireTcS ev s
; traceTcS "End solver pipeline (discharged) }" empty
; return () }
ContinueWith ct > do { addInertCan ct
; traceFireTcS (ctEvidence ct) (text "Kept as inert")
; traceTcS "End solver pipeline (kept as inert) }" $
(text "final_item =" <+> ppr ct) }
}
where run_pipeline :: [(String,SimplifierStage)] > StopOrContinue Ct
> TcS (StopOrContinue Ct)
run_pipeline [] res = return res
run_pipeline _ (Stop ev s) = return (Stop ev s)
run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
= do { traceTcS ("runStage " ++ stg_name ++ " {")
(text "workitem = " <+> ppr ct)
; res < stg ct
; traceTcS ("end stage " ++ stg_name ++ " }") empty
; run_pipeline stgs res }
{
Example 1:
Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
Reagent: a ~ [b] (given)
React with (c~d) ==> IR (ContinueWith (a~[b])) True []
React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t]
React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True []
Example 2:
Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty}
Reagent: a ~w [b]
React with (c ~w d) ==> IR (ContinueWith (a~[b])) True []
React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!)
etc.
Example 3:
Inert: {a ~ Int, F Int ~ b} (given)
Reagent: F a ~ b (wanted)
React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True []
React with (F Int ~ b) ==> IR Stop True []  after substituting we recanonicalize and get nothing
}
thePipeline :: [(String,SimplifierStage)]
thePipeline = [ ("canonicalization", TcCanonical.canonicalize)
, ("interact with inerts", interactWithInertsStage)
, ("toplevel reactions", topReactionsStage) ]
{
*********************************************************************************
* *
The interactwithinert Stage
* *
*********************************************************************************
Note [The Solver Invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We always add Givens first. So you might think that the solver has
the invariant
If the workitem is Given,
then the inert item must Given
But this isn't quite true. Suppose we have,
c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
After processing the first two, we get
c1: [G] beta ~ [alpha], c2 : [W] blah
Now, c3 does not interact with the given c1, so when we spontaneously
solve c3, we must rereact it with the inert set. So we can attempt a
reaction between inert c2 [W] and workitem c3 [G].
It *is* true that [Solver Invariant]
If the workitem is Given,
AND there is a reaction
then the inert item must Given
or, equivalently,
If the workitem is Given,
and the inert item is Wanted/Derived
then there is no reaction
}
 Interaction result of WorkItem <~> Ct
interactWithInertsStage :: WorkItem > TcS (StopOrContinue Ct)
 Precondition: if the workitem is a CTyEqCan then it will not be able to
 react with anything at this stage.
interactWithInertsStage wi
= do { inerts < getTcSInerts
; let ics = inert_cans inerts
; case wi of
CTyEqCan {} > interactTyVarEq ics wi
CFunEqCan {} > interactFunEq ics wi
CIrredCan {} > interactIrred ics wi
CDictCan {} > interactDict ics wi
_ > pprPanic "interactWithInerts" (ppr wi) }
 CHoleCan are put straight into inert_frozen, so never get here
 CNonCanonical have been canonicalised
data InteractResult
= KeepInert  Keep the inert item, and solve the work item from it
 (if the latter is Wanted; just discard it if not)
 KeepWork  Keep the work item, and solve the intert item from it
instance Outputable InteractResult where
ppr KeepInert = text "keep inert"
ppr KeepWork = text "keep workitem"
solveOneFromTheOther :: CtEvidence  Inert
> CtEvidence  WorkItem
> TcS InteractResult
 Precondition:
 * inert and work item represent evidence for the /same/ predicate

 We can always solve one from the other: even if both are wanted,
 although we don't rewrite wanteds with wanteds, we can combine
 two wanteds into one by solving one from the other
solveOneFromTheOther ev_i ev_w
 isDerived ev_w  Work item is Derived; just discard it
= return KeepInert
 isDerived ev_i  The inert item is Derived, we can just throw it away,
= return KeepWork  The ev_w is inert wrt earlier inertset items,
 so it's safe to continue on from this point
 CtWanted { ctev_loc = loc_w } < ev_w
, prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w
=  inert must be Given
do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
; return KeepWork }
 CtWanted {} < ev_w
 Inert is Given or Wanted
= return KeepInert
 From here on the workitem is Given
 CtWanted { ctev_loc = loc_i } < ev_i
, prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i
= do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
; return KeepInert }  Just discard the unusable Given
 This never actually happens because
 Givens get processed first
 CtWanted {} < ev_i
= return KeepWork
 From here on both are Given
 See Note [Replacement vs keeping]
 lvl_i == lvl_w
= do { ev_binds_var < getTcEvBindsVar
; binds < getTcEvBindsMap ev_binds_var
; return (same_level_strategy binds) }
 otherwise  Both are Given, levels differ
= return (different_level_strategy)
where
pred = ctEvPred ev_i
loc_i = ctEvLoc ev_i
loc_w = ctEvLoc ev_w
lvl_i = ctLocLevel loc_i
lvl_w = ctLocLevel loc_w
ev_id_i = ctEvEvId ev_i
ev_id_w = ctEvEvId ev_w
different_level_strategy
 isIPPred pred, lvl_w > lvl_i = KeepWork
 lvl_w < lvl_i = KeepWork
 otherwise = KeepInert
same_level_strategy binds  Both Given
 GivenOrigin (InstSC s_i) < ctLocOrigin loc_i
= case ctLocOrigin loc_w of
GivenOrigin (InstSC s_w)  s_w < s_i > KeepWork
 otherwise > KeepInert
_ > KeepWork
 GivenOrigin (InstSC {}) < ctLocOrigin loc_w
= KeepInert
 has_binding binds ev_id_w
, not (has_binding binds ev_id_i)
, not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))
= KeepWork
 otherwise
= KeepInert
has_binding binds ev_id = isJust (lookupEvBind binds ev_id)
{
Note [Replacement vs keeping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we have two Given constraints both of type (C tys), say, which should
we keep? More subtle than you might think!
* Constraints come from different levels (different_level_strategy)
 For implicit parameters we want to keep the innermost (deepest)
one, so that it overrides the outer one.
See Note [Shadowing of Implicit Parameters]
 For everything else, we want to keep the outermost one. Reason: that
makes it more likely that the inner one will turn out to be unused,
and can be reported as redundant. See Note [Tracking redundant constraints]
in TcSimplify.
It transpires that using the outermost one is reponsible for an
8% performance improvement in nofib cryptarithm2, compared to
just rolling the dice. I didn't investigate why.
* Constraints coming from the same level (i.e. same implication)
(a) Always get rid of InstSC ones if possible, since they are less
useful for solving. If both are InstSC, choose the one with
the smallest TypeSize
See Note [Solving superclass constraints] in TcInstDcls
(b) Keep the one that has a nontrivial evidence binding.
Example: f :: (Eq a, Ord a) => blah
then we may find [G] d3 :: Eq a
[G] d2 :: Eq a
with bindings d3 = sc_sel (d1::Ord a)
We want to discard d2 in favour of the superclass selection from
the Ord dictionary.
Why? See Note [Tracking redundant constraints] in TcSimplify again.
(c) But don't do (b) if the evidence binding depends transitively on the
one without a binding. Example (with RecursiveSuperClasses)
class C a => D a
class D a => C a
Inert: d1 :: C a, d2 :: D a
Binds: d3 = sc_sel d2, d2 = sc_sel d1
Work item: d3 :: C a
Then it'd be ridiculous to replace d1 with d3 in the inert set!
Hence the findNeedEvVars test. See Trac #14774.
* Finally, when there is still a choice, use KeepInert rather than
KeepWork, for two reasons:
 to avoid unnecessary munging of the inert set.
 to cut off superclass loops; see Note [Superclass loops] in TcCanonical
Doing the depthcheck for implicit parameters, rather than making the work item
always override, is important. Consider
data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }
f :: (?x::a) => T a > Int
f T1 = ?x
f T2 = 3
We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add
two new givens in the worklist: [G] (?x::Int)
[G] (a ~ Int)
Now consider these steps
 process a~Int, kicking out (?x::a)
 process (?x::Int), the inner given, adding to inert set
 process (?x::a), the outer given, overriding the inner given
Wrong! The depthcheck ensures that the inner implicit parameter wins.
(Actually I think that the order in which the worklist is processed means
that this chain of events won't happen, but that's very fragile.)
*********************************************************************************
* *
interactIrred
* *
*********************************************************************************
Note [Multiple matching irreds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You might think that it's impossible to have multiple irreds all match the
work item; after all, interactIrred looks for matches and solves one from the
other. However, note that interacting insoluble, nondroppable irreds does not
do this matching. We thus might end up with several insoluble, nondroppable,
matching irreds in the inert set. When another irred comes along that we have
not yet labeled insoluble, we can find multiple matches. These multiple matches
cause no harm, but it would be wrong to ASSERT that they aren't there (as we
once had done). This problem can be tickled by typecheck/should_compile/holes.
}
 Two pieces of irreducible evidence: if their types are *exactly identical*
 we can rewrite them. We can never improve using this:
 if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
 mean that (ty1 ~ ty2)
interactIrred :: InertCans > Ct > TcS (StopOrContinue Ct)
interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })
 insoluble  For insolubles, don't allow the constaint to be dropped
 which can happen with solveOneFromTheOther, so that
 we get distinct error messages with fdefertypeerrors
 See Note [Do not add duplicate derived insolubles]
, not (isDroppableCt workItem)
= continueWith workItem
 let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
, ((ct_i, swap) : _rest) < bagToList matching_irreds
 See Note [Multiple matching irreds]
, let ev_i = ctEvidence ct_i
= do { what_next < solveOneFromTheOther ev_i ev_w
; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)
; case what_next of
KeepInert > do { setEvBindIfWanted ev_w (swap_me swap ev_i)
; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
KeepWork > do { setEvBindIfWanted ev_i (swap_me swap ev_w)
; updInertIrreds (\_ > others)
; continueWith workItem } }
 otherwise
= continueWith workItem
where
swap_me :: SwapFlag > CtEvidence > EvExpr
swap_me swap ev
= case swap of
NotSwapped > ctEvExpr ev
IsSwapped > evCoercion (mkTcSymCo (evTermCoercion (EvExpr (ctEvExpr ev))))
interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
findMatchingIrreds :: Cts > CtEvidence > (Bag (Ct, SwapFlag), Bag Ct)
findMatchingIrreds irreds ev
 EqPred eq_rel1 lty1 rty1 < classifyPredType pred
 See Note [Solving irreducible equalities]
= partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds
 otherwise
= partitionBagWith match_non_eq irreds
where
pred = ctEvPred ev
match_non_eq ct
 ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)
 otherwise = Right ct
match_eq eq_rel1 lty1 rty1 ct
 EqPred eq_rel2 lty2 rty2 < classifyPredType (ctPred ct)
, eq_rel1 == eq_rel2
, Just swap < match_eq_help lty1 rty1 lty2 rty2
= Left (ct, swap)
 otherwise
= Right ct
match_eq_help lty1 rty1 lty2 rty2
 lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2
= Just NotSwapped
 lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2
= Just IsSwapped
 otherwise
= Nothing
{ Note [Solving irreducible equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #14333)
[G] a b ~R# c d
[W] c d ~R# a b
Clearly we should be able to solve this! Even though the constraints are
not decomposable. We solve this when looking up the workitem in the
irreducible constraints to look for an identical one. When doing this
lookup, findMatchingIrreds spots the equality case, and matches either
way around. It has to return a swapflag so we can generate evidence
that is the right way round too.
Note [Do not add duplicate derived insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general we *must* add an insoluble (Int ~ Bool) even if there is
one such there already, because they may come from distinct call
sites. Not only do we want an error message for each, but with
fdefertypeerrors we must generate evidence for each. But for
*derived* insolubles, we only want to report each one once. Why?
(a) A constraint (C r s t) where r > s, say, may generate the same fundep
equality many times, as the original constraint is successively rewritten.
(b) Ditto the successive iterations of the main solver itself, as it traverses
the constraint tree. See example below.
Also for *given* insolubles we may get repeated errors, as we
repeatedly traverse the constraint tree. These are relatively rare
anyway, so removing duplicates seems ok. (Alternatively we could take
the SrcLoc into account.)
Note that the test does not need to be particularly efficient because
it is only used if the program has a type error anyway.
Example of (b): assume a toplevel class and instance declaration:
class D a b  a > b
instance D [a] [a]
Assume we have started with an implication:
forall c. Eq c => { wc_simple = D [c] c [W] }
which we have simplified to:
forall c. Eq c => { wc_simple = D [c] c [W]
(c ~ [c]) [D] }
For some reason, e.g. because we floated an equality somewhere else,
we might try to resolve this implication. If we do not do a
dropDerivedWC, then we will end up trying to solve the following
constraints the second time:
(D [c] c) [W]
(c ~ [c]) [D]
which will result in two Deriveds to end up in the insoluble set:
wc_simple = D [c] c [W]
(c ~ [c]) [D], (c ~ [c]) [D]
}
{
*********************************************************************************
* *
interactDict
* *
*********************************************************************************
Note [Shortcut solving]
~~~~~~~~~~~~~~~~~~~~~~~
When we interact a [W] constraint with a [G] constraint that solves it, there is
a possibility that we could produce better code if instead we solved from a
toplevel instance declaration (See #12791, #5835). For example:
class M a b where m :: a > b
type C a b = (Num a, M a b)
f :: C Int b => b > Int > Int
f _ x = x + 1
The body of `f` requires a [W] `Num Int` instance. We could solve this
constraint from the givens because we have `C Int b` and that provides us a
solution for `Num Int`. This would let us produce core like the following
(with O2):
f :: forall b. C Int b => b > Int > Int
f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) >
+ @ Int
(GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))
eta1
A.f1
This is bad! We could do /much/ better if we solved [W] `Num Int` directly
from the instance that we have in scope:
f :: forall b. C Int b => b > Int > Int
f = \ (@ b) _ _ (x :: Int) >
case x of { GHC.Types.I# x1 > GHC.Types.I# (GHC.Prim.+# x1 1#) }
** NB: It is important to emphasize that all this is purely an optimization:
** exactly the same programs should typecheck with or without this
** procedure.
Solving fully
~~~~~~~~~~~~~
There is a reason why the solver does not simply try to solve such
constraints with toplevel instances. If the solver finds a relevant
instance declaration in scope, that instance may require a context
that can't be solved for. A good example of this is:
f :: Ord [a] => ...
f x = ..Need Eq [a]...
If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
be left with the obligation to solve the constraint Eq a, which we cannot. So we
must be conservative in our attempt to use an instance declaration to solve the
[W] constraint we're interested in.
Our rule is that we try to solve all of the instance's subgoals
recursively all at once. Precisely: We only attempt to solve
constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
are themselves class constraints of the form `C1', ... Cm' => C' t1'
... tn'` and we only succeed if the entire tree of constraints is
solvable from instances.
An example that succeeds:
class Eq a => C a b  b > a where
m :: b > a
f :: C [Int] b => b > Bool
f x = m x == []
We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This
produces the following core:
f :: forall b. C [Int] b => b > Bool
f = \ (@ b) ($dC :: C [Int] b) (x :: b) >
GHC.Classes.$fEq[]_$s$c==
(m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)
An example that fails:
class Eq a => C a b  b > a where
m :: b > a
f :: C [a] b => b > Bool
f x = m x == []
Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:
f :: forall a b. C [a] b => b > Bool
f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) >
==
@ [a]
(A.$p1C @ [a] @ b $dC)
(m @ [a] @ b $dC eta)
(GHC.Types.[] @ a)
Note [Shortcut solving: type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have (Trac #13943)
class Take (n :: Nat) where ...
instance {# OVERLAPPING #} Take 0 where ..
instance {# OVERLAPPABLE #} (Take (n  1)) => Take n where ..
And we have [W] Take 3. That only matches one instance so we get
[W] Take (31). Really we should now flatten to reduce the (31) to 2, and
so on  but that is reproducing yet more of the solver. Sigh. For now,
we just give up (remember all this is just an optimisation).
But we must not just naively try to lookup (Take (31)) in the
InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
unique match on the (Take n) instance. That leads immediately to an
infinite loop. Hence the check that 'preds' have no type families
(isTyFamFree).
Note [Shortcut solving: overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
instance {# OVERLAPPABLE #} C a where ...
and we are typechecking
f :: C a => a > a
f = e  Gives rise to [W] C a
We don't want to solve the wanted constraint with the overlappable
instance; rather we want to use the supplied (C a)! That was the whole
point of it being overlappable! Trac #14434 wwas an example.
Note [Shortcut solving: incoherence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This optimization relies on coherence of dictionaries to be correct. When we
cannot assume coherence because of IncoherentInstances then this optimization
can change the behavior of the user's code.
The following four modules produce a program whose output would change depending
on whether we apply this optimization when IncoherentInstances is in effect:
#########
{# LANGUAGE MultiParamTypeClasses #}
module A where
class A a where
int :: a > Int
class A a => C a b where
m :: b > a > a
#########
{# LANGUAGE MultiParamTypeClasses, FlexibleInstances #}
module B where
import A
instance A a where
int _ = 1
instance C a [b] where
m _ = id
#########
{# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #}
{# LANGUAGE IncoherentInstances #}
module C where
import A
instance A Int where
int _ = 2
instance C Int [Int] where
m _ = id
intC :: C Int a => a > Int > Int
intC _ x = int x
#########
module Main where
import A
import B
import C
main :: IO ()
main = print (intC [] (0::Int))
The output of `main` if we avoid the optimization under the effect of
IncoherentInstances is `1`. If we were to do the optimization, the output of
`main` would be `2`.
Note [Shortcut try_solve_from_instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The workhorse of the shortcut solver is
try_solve_from_instance :: CtLoc
> (EvBindMap, DictMap CtEvidence)
> CtEvidence  Solve this
> MaybeT TcS (EvBindMap, DictMap CtEvidence)
Note that:
* The CtEvidence is teh goal to be solved
* The MaybeT anages early failure if we find a subgoal that
cannot be solved from instances.
* The (EvBindMap, DictMap CtEvidence) is an accumulating purelyfunctional
state that allows try_solve_from_instance to augmennt the evidence
bindings and inert_solved_dicts as it goes.
If it succeeds, we commit all these bindings and solved dicts to the
main TcS InertSet. If not, we abandon it all entirely.
Passing along the solved_dicts important for two reasons:
* We need to be able to handle recursive super classes. The
solved_dicts state ensures that we remember what we have already
tried to solve to avoid looping.
* As Trac #15164 showed, it can be important to exploit sharing between
goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
and to solve G2 we may need H. If we don't spot this sharing we may
solve H twice; and if this pattern repeats we may get exponentially bad
behaviour.
}
interactDict :: InertCans > Ct > TcS (StopOrContinue Ct)
interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
 Just ev_i < lookupInertDict inerts (ctEvLoc ev_w) cls tys
=  There is a matching dictionary in the inert set
do {  First to try to solve it /completely/ from top level instances
 See Note [Shortcut solving]
dflags < getDynFlags
; short_cut_worked < shortCutSolver dflags ev_w ev_i
; if short_cut_worked
then stopWith ev_w "interactDict/solved from instance"
else
do {  We were unable to solve the [W] constraint from inscope
 instances so we solve it from the matching inert we found
what_next < solveOneFromTheOther ev_i ev_w
; traceTcS "lookupInertDict" (ppr what_next)
; case what_next of
KeepInert > do { setEvBindIfWanted ev_w (ctEvExpr ev_i)
; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
KeepWork > do { setEvBindIfWanted ev_i (ctEvExpr ev_w)
; updInertDicts $ \ ds > delDict ds cls tys
; continueWith workItem } } }
 cls `hasKey` ipClassKey
, isGiven ev_w
= interactGivenIP inerts workItem
 otherwise
= do { addFunDepWork inerts ev_w cls
; continueWith workItem }
interactDict _ wi = pprPanic "interactDict" (ppr wi)
 See Note [Shortcut solving]
shortCutSolver :: DynFlags
> CtEvidence  Work item
> CtEvidence  Inert we want to try to replace
> TcS Bool  True <=> success
shortCutSolver dflags ev_w ev_i
 isWanted ev_w
&& isGiven ev_i
 We are about to solve a [W] constraint from a [G] constraint. We take
 a moment to see if we can get a better solution using an instance.
 Note that we only do this for the sake of performance. Exactly the same
 programs should typecheck regardless of whether we take this step or
 not. See Note [Shortcut solving]
&& not (xopt LangExt.IncoherentInstances dflags)
 If IncoherentInstances is on then we cannot rely on coherence of proofs
 in order to justify this optimization: The proof provided by the
 [G] constraint's superclass may be different from the toplevel proof.
 See Note [Shortcut solving: incoherence]
&& gopt Opt_SolveConstantDicts dflags
 Enabled by the fsolveconstantdicts flag
= do { ev_binds_var < getTcEvBindsVar
; ev_binds < ASSERT2( not (isNoEvBindsVar ev_binds_var ), ppr ev_w )
getTcEvBindsMap ev_binds_var
; solved_dicts < getSolvedDicts
; mb_stuff < runMaybeT $ try_solve_from_instance loc_w
(ev_binds, solved_dicts) ev_w
; case mb_stuff of
Nothing > return False
Just (ev_binds', solved_dicts')
> do { setTcEvBindsMap ev_binds_var ev_binds'
; setSolvedDicts solved_dicts'
; return True } }
 otherwise
= return False
where
 This `CtLoc` is used only to check the wellstaged condition of any
 candidate DFun. Our subgoals all have the same stage as our root
 [W] constraint so it is safe to use this while solving them.
loc_w = ctEvLoc ev_w
try_solve_from_instance  See Note [Shortcut try_solve_from_instance]
:: CtLoc > (EvBindMap, DictMap CtEvidence) > CtEvidence
> MaybeT TcS (EvBindMap, DictMap CtEvidence)
try_solve_from_instance loc (ev_binds, solved_dicts) ev
 let pred = ctEvPred ev
, ClassPred cls tys < classifyPredType pred
= do { inst_res < lift $ match_class_inst dflags True cls tys loc_w
; case inst_res of
GenInst { lir_new_theta = preds
, lir_mk_ev = mk_ev
, lir_safe_over = safeOverlap }
 safeOverlap
, all isTyFamFree preds  Note [Shortcut solving: type families]
> do { let solved_dicts' = addDict solved_dicts cls tys ev
loc' = bumpCtLocDepth loc
 solved_dicts': it is important that we add our goal
 to the cache before we solve! Otherwise we may end
 up in a loop while solving recursive dictionaries.
; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
; lift $ checkReductionDepth loc' pred
; evc_vs < mapM (new_wanted_cached solved_dicts') preds
 Emit work for subgoals but use our local cache
 so we can solve recursive dictionaries.
; let ev_tm = mk_ev (map getEvExpr evc_vs)
ev_binds' = extendEvBinds ev_binds $
mkWantedEvBind (ctEvEvId ev) ev_tm
; foldlM (try_solve_from_instance loc')
(ev_binds', solved_dicts')
(freshGoals evc_vs) }
_ > mzero }
 otherwise = mzero
 Use a local cache of solved dicts while emitting EvVars for new work
 We bail out of the entire computation if we need to emit an EvVar for
 a subgoal that isn't a ClassPred.
new_wanted_cached :: DictMap CtEvidence > TcPredType > MaybeT TcS MaybeNew
new_wanted_cached cache pty
 ClassPred cls tys < classifyPredType pty
= lift $ case findDict cache loc_w cls tys of
Just ctev > return $ Cached (ctEvExpr ctev)
Nothing > Fresh <$> newWantedNC loc_w pty
 otherwise = mzero
addFunDepWork :: InertCans > CtEvidence > Class > TcS ()
 Add derived constraints from typeclass functional dependencies.
addFunDepWork inerts work_ev cls
 isImprovable work_ev
= mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)
 No need to check flavour; fundeps work between
 any pair of constraints, regardless of flavour
 Importantly we don't throw workitem back in the
 worklist because this can cause loops (see #5236)
 otherwise
= return ()
where
work_pred = ctEvPred work_ev
work_loc = ctEvLoc work_ev
add_fds inert_ct
 isImprovable inert_ev
= do { traceTcS "addFunDepWork" (vcat
[ ppr work_ev
, pprCtLoc work_loc, ppr (isGivenLoc work_loc)
, pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
, pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;
emitFunDepDeriveds $
improveFromAnother derived_loc inert_pred work_pred
 We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
 NB: We do create FDs for given to report insoluble equations that arise
 from pairs of Givens, and also because of floating when we approximate
 implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
}
 otherwise
= return ()
where
inert_ev = ctEvidence inert_ct
inert_pred = ctEvPred inert_ev
inert_loc = ctEvLoc inert_ev
derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth`
ctl_depth inert_loc
, ctl_origin = FunDepOrigin1 work_pred work_loc
inert_pred inert_loc }
{
**********************************************************************
* *
Implicit parameters
* *
**********************************************************************
}
interactGivenIP :: InertCans > Ct > TcS (StopOrContinue Ct)
 Work item is Given (?x:ty)
 See Note [Shadowing of Implicit Parameters]
interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
, cc_tyargs = tys@(ip_str:_) })
= do { updInertCans $ \cans > cans { inert_dicts = addDict filtered_dicts cls tys workItem }
; stopWith ev "Given IP" }
where
dicts = inert_dicts inerts
ip_dicts = findDictsByClass dicts cls
other_ip_dicts = filterBag (not . is_this_ip) ip_dicts
filtered_dicts = addDictsByClass dicts cls other_ip_dicts
 Pick out any Given constraints for the same implicit parameter
is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })
= isGiven ev && ip_str `tcEqType` ip_str'
is_this_ip _ = False
interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
{ Note [Shadowing of Implicit Parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example:
f :: (?x :: Char) => Char
f = let ?x = 'a' in ?x
The "let ?x = ..." generates an implication constraint of the form:
?x :: Char => ?x :: Char
Furthermore, the signature for `f` also generates an implication
constraint, so we end up with the following nested implication:
?x :: Char => (?x :: Char => ?x :: Char)
Note that the wanted (?x :: Char) constraint may be solved in
two incompatible ways: either by using the parameter from the
signature, or by using the local definition. Our intention is
that the local definition should "shadow" the parameter of the
signature, and we implement this as follows: when we add a new
*given* implicit parameter to the inert set, it replaces any existing
givens for the same implicit parameter.
Similarly, consider
f :: (?x::a) => Bool > a
g v = let ?x::Int = 3
in (f v, let ?x::Bool = True in f v)
This should probably be well typed, with
g :: Bool > (Int, Bool)
So the inner binding for ?x::Bool *overrides* the outer one.
All this works for the normal cases but it has an odd side effect in
some pathological programs like this:
 This is accepted, the second parameter shadows
f1 :: (?x :: Int, ?x :: Char) => Char
f1 = ?x
 This is rejected, the second parameter shadows
f2 :: (?x :: Int, ?x :: Char) => Int
f2 = ?x
Both of these are actually wrong: when we try to use either one,
we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char),
which would lead to an error.
I can think of two ways to fix this:
1. Simply disallow multiple constraints for the same implicit
parameterthis is never useful, and it can be detected completely
syntactically.
2. Move the shadowing machinery to the location where we nest
implications, and add some code here that will produce an
error if we get multiple givens for the same implicit parameter.
**********************************************************************
* *
interactFunEq
* *
**********************************************************************
}
interactFunEq :: InertCans > Ct > TcS (StopOrContinue Ct)
 Try interacting the work item with the inert set
interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc
, cc_tyargs = args, cc_fsk = fsk })
 Just inert_ct@(CFunEqCan { cc_ev = ev_i
, cc_fsk = fsk_i })
< findFunEq (inert_funeqs inerts) tc args
, pr@(swap_flag, upgrade_flag) < ev_i `funEqCanDischarge` ev
= do { traceTcS "reactFunEq (rewrite inert item):" $
vcat [ text "work_item =" <+> ppr work_item
, text "inertItem=" <+> ppr ev_i
, text "(swap_flag, upgrade)" <+> ppr pr ]
; if isSwapped swap_flag
then do {  Rewrite inert using workitem
let work_item'  upgrade_flag = upgradeWanted work_item
 otherwise = work_item
; updInertFunEqs $ \ feqs > insertFunEq feqs tc args work_item'
 Do the updInertFunEqs before the reactFunEq, so that
 we don't kick out the inertItem as well as consuming it!
; reactFunEq ev fsk ev_i fsk_i
; stopWith ev "Work item rewrites inert" }
else do {  Rewrite workitem using inert
; when upgrade_flag $
updInertFunEqs $ \ feqs > insertFunEq feqs tc args
(upgradeWanted inert_ct)
; reactFunEq ev_i fsk_i ev fsk
; stopWith ev "Inert rewrites work item" } }
 otherwise  Try improvement
= do { improveLocalFunEqs ev inerts tc args fsk
; continueWith work_item }
interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)
upgradeWanted :: Ct > Ct
 We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2
 so upgrade the [W] to [WD] before putting it in the inert set
upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }
where
upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )
ev { ctev_nosh = WDeriv }
improveLocalFunEqs :: CtEvidence > InertCans > TyCon > [TcType] > TcTyVar
> TcS ()
 Generate derived improvement equalities, by comparing
 the current work item with inert CFunEqs
 E.g. x + y ~ z, x + y' ~ z => [D] y ~ y'

 See Note [FunDep and implicit parameter reactions]
improveLocalFunEqs work_ev inerts fam_tc args fsk
 isGiven work_ev  See Note [No FunEq improvement for Givens]
 not (isImprovable work_ev)
= return ()
 not (null improvement_eqns)
= do { traceTcS "interactFunEq improvements: " $
vcat [ text "Eqns:" <+> ppr improvement_eqns
, text "Candidates:" <+> ppr funeqs_for_tc
, text "Inert eqs:" <+> ppr ieqs ]
; emitFunDepDeriveds improvement_eqns }
 otherwise
= return ()
where
ieqs = inert_eqs inerts
funeqs = inert_funeqs inerts
funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc
rhs = lookupFlattenTyVar ieqs fsk
work_loc = ctEvLoc work_ev
work_pred = ctEvPred work_ev
fam_inj_info = tyConInjectivityInfo fam_tc

improvement_eqns :: [FunDepEqn CtLoc]
improvement_eqns
 Just ops < isBuiltInSynFamTyCon_maybe fam_tc
=  Try builtin families, notably for arithmethic
concatMap (do_one_built_in ops) funeqs_for_tc
 Injective injective_args < fam_inj_info
=  Try improvement from type families with injectivity annotations
concatMap (do_one_injective injective_args) funeqs_for_tc
 otherwise
= []

do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })
= mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs
(lookupFlattenTyVar ieqs ifsk))
do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)

 See Note [Type inference for type families with injectivity]
do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args
, cc_fsk = ifsk, cc_ev = inert_ev })
 isImprovable inert_ev
, rhs `tcEqType` lookupFlattenTyVar ieqs ifsk
= mk_fd_eqns inert_ev $
[ Pair arg iarg
 (arg, iarg, True) < zip3 args inert_args inj_args ]
 otherwise
= []
do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)

mk_fd_eqns :: CtEvidence > [TypeEqn] > [FunDepEqn CtLoc]
mk_fd_eqns inert_ev eqns
 null eqns = []
 otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
, fd_pred1 = work_pred
, fd_pred2 = ctEvPred inert_ev
, fd_loc = loc } ]
where
inert_loc = ctEvLoc inert_ev
loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
ctl_depth work_loc }

reactFunEq :: CtEvidence > TcTyVar  From this :: F args1 ~ fsk1
> CtEvidence > TcTyVar  Solve this :: F args2 ~ fsk2
> TcS ()
reactFunEq from_this fsk1 solve_this fsk2
  CtGiven { ctev_evar = evar, ctev_loc = loc } < solve_this
 = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo`
 ctEvCoercion from_this
  :: fsk2 ~ fsk1
 fsk_eq_pred = mkTcEqPredLikeEv solve_this
 (mkTyVarTy fsk2) (mkTyVarTy fsk1)

 ; new_ev < newGivenEvVar loc (fsk_eq_pred, evCoercion fsk_eq_co)
 ; emitWorkNC [new_ev] }

  otherwise  Wanted
 = do { traceTcS "reactFunEq (Wanted/Derived)"
+ = do { traceTcS "reactFunEq"
(vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
 ; dischargeFmv solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
+ ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
ppr solve_this $$ ppr fsk2) }
{ Note [Type inference for type families with injectivity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have a type family with an injectivity annotation:
type family F a b = r  r > b
Then if we have two CFunEqCan constraints for F with the same RHS
F s1 t1 ~ rhs
F s2 t2 ~ rhs
then we can use the injectivity to get a new Derived constraint on
the injective argument
[D] t1 ~ t2
That in turn can help GHC solve constraints that would otherwise require
guessing. For example, consider the ambiguity check for
f :: F Int b > Int
We get the constraint
[W] F Int b ~ F Int beta
where beta is a unification variable. Injectivity lets us pick beta ~ b.
Injectivity information is also used at the call sites. For example:
g = f True
gives rise to
[W] F Int b ~ Bool
from which we can derive b. This requires looking at the defining equations of
a type family, ie. finding equation with a matching RHS (Bool in this example)
and infering values of type variables (b in this example) from the LHS patterns
of the matching equation. For closed type families we have to perform
additional apartness check for the selected equation to check that the selected
is guaranteed to fire for given LHS arguments.
These new constraints are simply *Derived* constraints; they have no evidence.
We could go further and offer evidence from decomposing injective typefunction
applications, but that would require new evidence forms, and an extension to
FC, so we don't do that right now (Dec 14).
See also Note [Injective type families] in TyCon
Note [Cachecaused loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
solved cache (which is the default behaviour or xCtEvidence), because the interaction
may not be contributing towards a solution. Here is an example:
Initial inert set:
[W] g1 : F a ~ beta1
Work item:
[W] g2 : F a ~ beta2
The work item will react with the inert yielding the _same_ inert set plus:
(i) Will set g2 := g1 `cast` g3
(ii) Will add to our solved cache that [S] g2 : F a ~ beta2
(iii) Will emit [W] g3 : beta1 ~ beta2
Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
will set
g1 := g ; sym g3
and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
remember that we have this in our solved cache, and it is ... g2! In short we
created the evidence loop:
g2 := g1 ; g3
g3 := refl
g1 := g2 ; sym g3
To avoid this situation we do not cache as solved any workitems (or inert)
which did not really made a 'step' towards proving some goal. Solved's are
just an optimization so we don't lose anything in terms of completeness of
solving.
Note [Efficient Orientation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are interacting two FunEqCans with the same LHS:
(inert) ci :: (F ty ~ xi_i)
(work) cw :: (F ty ~ xi_w)
We prefer to keep the inert (else we pass the work item on down
the pipeline, which is a bit silly). If we keep the inert, we
will (a) discharge 'cw'
(b) produce a new equality workitem (xi_w ~ xi_i)
Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
new_work :: xi_w ~ xi_i
cw := ci ; sym new_work
Why? Consider the simplest case when xi1 is a type variable. If
we generate xi1~xi2, porcessing that constraint will kick out 'ci'.
If we generate xi2~xi1, there is less chance of that happening.
Of course it can and should still happen if xi1=a, xi1=Int, say.
But we want to avoid it happening needlessly.
Similarly, if we *can't* keep the inert item (because inert is Wanted,
and work is Given, say), we prefer to orient the new equality (xi_i ~
xi_w).
Note [Carefully solve the right CFunEqCan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 OLD COMMENT, NOW NOT NEEDED
 because we now allow multiple
 wanted FunEqs with the same head
Consider the constraints
c1 :: F Int ~ a  Arising from an application line 5
c2 :: F Int ~ Bool  Arising from an application line 10
Suppose that 'a' is a unification variable, arising only from
flattening. So there is no error on line 5; it's just a flattening
variable. But there is (or might be) an error on line 10.
Two ways to combine them, leaving either (Plan A)
c1 :: F Int ~ a  Arising from an application line 5
c3 :: a ~ Bool  Arising from an application line 10
or (Plan B)
c2 :: F Int ~ Bool  Arising from an application line 10
c4 :: a ~ Bool  Arising from an application line 5
Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
on the *totally innocent* line 5. An example is test SimpleFail16
where the expected/actual message comes out backwards if we use
the wrong plan.
The second is the right thing to do. Hence the isMetaTyVarTy
test when solving pairwise CFunEqCan.
**********************************************************************
* *
interactTyVarEq
* *
**********************************************************************
}
inertsCanDischarge :: InertCans > TcTyVar > TcType > CtFlavourRole
> Maybe ( CtEvidence  The evidence for the inert
, SwapFlag  Whether we need mkSymCo
, Bool)  True <=> keep a [D] version
 of the [WD] constraint
inertsCanDischarge inerts tv rhs fr
 (ev_i : _) < [ ev_i  CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
, cc_eq_rel = eq_rel }
< findTyEqs inerts tv
, (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
, rhs_i `tcEqType` rhs ]
=  Inert: a ~ ty
 Work item: a ~ ty
Just (ev_i, NotSwapped, keep_deriv ev_i)
 Just tv_rhs < getTyVar_maybe rhs
, (ev_i : _) < [ ev_i  CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
, cc_eq_rel = eq_rel }
< findTyEqs inerts tv_rhs
, (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
, rhs_i `tcEqType` mkTyVarTy tv ]
=  Inert: a ~ b
 Work item: b ~ a
Just (ev_i, IsSwapped, keep_deriv ev_i)
 otherwise
= Nothing
where
keep_deriv ev_i
 Wanted WOnly < ctEvFlavour ev_i  inert is [W]
, (Wanted WDeriv, _) < fr  work item is [WD]
= True  Keep a derived verison of the work item
 otherwise
= False  Work item is fully discharged
interactTyVarEq :: InertCans > Ct > TcS (StopOrContinue Ct)
 CTyEqCans are always consumed, so always returns Stop
interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
, cc_rhs = rhs
, cc_ev = ev
, cc_eq_rel = eq_rel })
 Just (ev_i, swapped, keep_deriv)
< inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
= do { setEvBindIfWanted ev $
evCoercion (maybeSym swapped $
tcDowngradeRole (eqRelRole eq_rel)
(ctEvRole ev_i)
(ctEvCoercion ev_i))
; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev
, ctev_loc = ctEvLoc ev }
; when keep_deriv $
emitWork [workItem { cc_ev = deriv_ev }]
 As a Derived it might not be fully rewritten,
 so we emit it as new work
; stopWith ev "Solved from inert" }
 ReprEq < eq_rel  See Note [Do not unify representational equalities]
= unsolved_inert
 isGiven ev  See Note [Touchables and givens]
= unsolved_inert
 otherwise
= do { tclvl < getTcLevel
; if canSolveByUnification tclvl tv rhs
then do { solveByUnification ev tv rhs
; n_kicked < kickOutAfterUnification tv
; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
else unsolved_inert }
where
unsolved_inert
= do { traceTcS "Can't solve tyvar equality"
(vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)
, ppWhen (isMetaTyVar tv) $
nest 4 (text "TcLevel of" <+> ppr tv
<+> text "is" <+> ppr (metaTyVarTcLevel tv))
, text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) ])
; addInertEq workItem
; stopWith ev "Kept as inert" }
interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
solveByUnification :: CtEvidence > TcTyVar > Xi > TcS ()
 Solve with the identity coercion
 Precondition: kind(xi) equals kind(tv)
 Precondition: CtEvidence is Wanted or Derived
 Precondition: CtEvidence is nominal
 Returns: workItem where
 workItem = the new Given constraint

 NB: No need for an occurs check here, because solveByUnification always
 arises from a CTyEqCan, a *canonical* constraint. Its invariants
 say that in (a ~ xi), the type variable a does not appear in xi.
 See TcRnTypes.Ct invariants.

 Post: tv is unified (by side effect) with xi;
 we often write tv := xi
solveByUnification wd tv xi
= do { let tv_ty = mkTyVarTy tv
; traceTcS "Sneaky unification:" $
vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
text "Coercion:" <+> pprEq tv_ty xi,
text "Left Kind is:" <+> ppr (typeKind tv_ty),
text "Right Kind is:" <+> ppr (typeKind xi) ]
; unifyTyVar tv xi
; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }
{ Note [Avoid double unifications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The spontaneous solver has to return a given which mentions the unified unification
variable *on the left* of the equality. Here is what happens if not:
Original wanted: (a ~ alpha), (alpha ~ Int)
We spontaneously solve the first wanted, without changing the order!
given : a ~ alpha [having unified alpha := a]
Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.
At the end we spontaneously solve that guy, *reunifying* [alpha := Int]
We avoid this problem by orienting the resulting given so that the unification
variable is on the left. [Note that alternatively we could attempt to
enforce this at canonicalization]
See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
double unifications is the main reason we disallow touchable
unification variables as RHS of type family equations: F xis ~ alpha.
Note [Do not unify representational equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [W] alpha ~R# b
where alpha is touchable. Should we unify alpha := b?
Certainly not! Unifying forces alpha and be to be the same; but they
only need to be representationally equal types.
For example, we might have another constraint [W] alpha ~# N b
where
newtype N b = MkN b
and we want to get alpha := N b.
See also Trac #15144, which was caused by unifying a representational
equality (in the unflattener).
************************************************************************
* *
* Functional dependencies, instantiation of equations
* *
************************************************************************
When we spot an equality arising from a functional dependency,
we now use that equality (a "wanted") to rewrite the workitem
constraint right away. This avoids two dangers
Danger 1: If we send the original constraint on down the pipeline
it may react with an instance declaration, and in delicate
situations (when a Given overlaps with an instance) that
may produce new insoluble goals: see Trac #4952
Danger 2: If we don't rewrite the constraint, it may rereact
with the same thing later, and produce the same equality
again > termination worries.
To achieve this required some refactoring of FunDeps.hs (nicer
now!).
Note [FunDep and implicit parameter reactions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently, our story of interacting two dictionaries (or a dictionary
and toplevel instances) for functional dependencies, and implicit
parameters, is that we simply produce new Derived equalities. So for example
class D a b  a > b where ...
Inert:
d1 :g D Int Bool
WorkItem:
d2 :w D Int alpha
We generate the extra work item
cv :d alpha ~ Bool
where 'cv' is currently unused. However, this new item can perhaps be
spontaneously solved to become given and react with d2,
discharging it in favour of a new constraint d2' thus:
d2' :w D Int Bool
d2 := d2' > D Int cv
Now d2' can be discharged from d1
We could be more aggressive and try to *immediately* solve the dictionary
using those extra equalities, but that requires those equalities to carry
evidence and derived do not carry evidence.
If that were the case with the same inert set and work item we might dischard
d2 directly:
cv :w alpha ~ Bool
d2 := d1 > D Int cv
But in general it's a bit painful to figure out the necessary coercion,
so we just take the first approach. Here is a better example. Consider:
class C a b c  a > b
And:
[Given] d1 : C T Int Char
[Wanted] d2 : C T beta Int
In this case, it's *not even possible* to solve the wanted immediately.
So we should simply output the functional dependency and add this guy
[but NOT its superclasses] back in the worklist. Even worse:
[Given] d1 : C T Int beta
[Wanted] d2: C T beta Int
Then it is solvable, but its very hard to detect this on the spot.
It's exactly the same with implicit parameters, except that the
"aggressive" approach would be much easier to implement.
Note [Weird fundeps]
~~~~~~~~~~~~~~~~~~~~
Consider class Het a b  a > b where
het :: m (f c) > a > m b
class GHet (a :: * > *) (b :: * > *)  a > b
instance GHet (K a) (K [a])
instance Het a b => GHet (K a) (K b)
The two instances don't actually conflict on their fundeps,
although it's pretty strange. So they are both accepted. Now
try [W] GHet (K Int) (K Bool)
This triggers fundeps from both instance decls;
[D] K Bool ~ K [a]
[D] K Bool ~ K beta
And there's a risk of complaining about Bool ~ [a]. But in fact
the Wanted matches the second instance, so we never get as far
as the fundeps.
Trac #7875 is a case in point.
}
emitFunDepDeriveds :: [FunDepEqn CtLoc] > TcS ()
 See Note [FunDep and implicit parameter reactions]
emitFunDepDeriveds fd_eqns
= mapM_ do_one_FDEqn fd_eqns
where
do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
 null tvs  Common shortcut
= do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
; mapM_ (unifyDerived loc Nominal) eqs }
 otherwise
= do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr eqs)
; subst < instFlexi tvs  Takes account of kind substitution
; mapM_ (do_one_eq loc subst) eqs }
do_one_eq loc subst (Pair ty1 ty2)
= unifyDerived loc Nominal $
Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)
{
**********************************************************************
* *
The topreaction Stage
* *
**********************************************************************
}
topReactionsStage :: WorkItem > TcS (StopOrContinue Ct)
topReactionsStage wi
= do { tir < doTopReact wi
; case tir of
ContinueWith wi > continueWith wi
Stop ev s > return (Stop ev (text "Top react:" <+> s)) }
doTopReact :: WorkItem > TcS (StopOrContinue Ct)
 The work item does not react with the inert set, so try interaction with toplevel
 instances. Note:

 (a) The place to add superclasses in not here in doTopReact stage.
 Instead superclasses are added in the worklist as part of the
 canonicalization process. See Note [Adding superclasses].
doTopReact work_item
= do { traceTcS "doTopReact" (ppr work_item)
; case work_item of
CDictCan {} > do { inerts < getTcSInerts
; doTopReactDict inerts work_item }
CFunEqCan {} > doTopReactFunEq work_item
_ >  Any other work item does not react with any toplevel equations
continueWith work_item }

doTopReactFunEq :: Ct > TcS (StopOrContinue Ct)
doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
, cc_tyargs = args, cc_fsk = fsk })
 fsk `elemVarSet` tyCoVarsOfTypes args
= no_reduction  See Note [FunEq occurscheck principle]
 otherwise  Note [Reduction for Derived CFunEqCans]
= do { match_res < matchFam fam_tc args
 Look up in toplevel instances, or builtin axiom
 See Note [MATCHINGSYNONYMS]
; case match_res of
Nothing > no_reduction
Just match_info > reduce_top_fun_eq old_ev fsk match_info }
where
no_reduction
= do { improveTopFunEqs old_ev fam_tc args fsk
; continueWith work_item }
doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
reduce_top_fun_eq :: CtEvidence > TcTyVar > (TcCoercion, TcType)
> TcS (StopOrContinue Ct)
 We have found an applicable toplevel axiom: use it to reduce
 Precondition: fsk is not free in rhs_ty
 old_ev is not Derived
reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
  isDerived old_ev
 = do { emitNewDerivedEq loc Nominal (mkTyVarTy fsk) rhs_ty
 ; stopWith old_ev "Fun/Top (derived)" }

  Just (tc, tc_args) < tcSplitTyConApp_maybe rhs_ty
+  not (isDerived old_ev)  Precondition of shortCutReduction
+ , Just (tc, tc_args) < tcSplitTyConApp_maybe rhs_ty
, isTypeFamilyTyCon tc
, tc_args `lengthIs` tyConArity tc  Shortcut
=  RHS is another typefamily application
 Try shortcut; see Note [Toplevel reductions for type functions]
 shortCutReduction old_ev fsk ax_co tc tc_args

  isGiven old_ev  Not shortcut
 = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co
  final_co :: fsk ~ rhs_ty
 ; new_ev < newGivenEvVar deeper_loc (mkPrimEqPred (mkTyVarTy fsk) rhs_ty,
 evCoercion final_co)
 ; emitWorkNC [new_ev]  Noncannonical; that will mean we flatten rhs_ty
 ; stopWith old_ev "Fun/Top (given)" }
+ do { shortCutReduction old_ev fsk ax_co tc tc_args
+ ; stopWith old_ev "Fun/Top (shortcut)" }
  otherwise  So old_ev is Wanted (cannot be Derived)
+  otherwise
= ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
, ppr old_ev $$ ppr rhs_ty )
 Guaranteed by Note [FunEq occurscheck principle]
 do { dischargeFmv old_ev fsk ax_co rhs_ty
+ do { dischargeFunEq old_ev fsk ax_co rhs_ty
; traceTcS "doTopReactFunEq" $
vcat [ text "old_ev:" <+> ppr old_ev
, nest 2 (text ":=") <+> ppr ax_co ]
 ; stopWith old_ev "Fun/Top (wanted)" }

 where
 loc = ctEvLoc old_ev
 deeper_loc = bumpCtLocDepth loc
+ ; stopWith old_ev "Fun/Top" }
improveTopFunEqs :: CtEvidence > TyCon > [TcType] > TcTyVar > TcS ()
 See Note [FunDep and implicit parameter reactions]
improveTopFunEqs ev fam_tc args fsk
 isGiven ev  See Note [No FunEq improvement for Givens]
 not (isImprovable ev)
= return ()
 otherwise
= do { ieqs < getInertEqs
; fam_envs < getFamInstEnvs
; eqns < improve_top_fun_eqs fam_envs fam_tc args
(lookupFlattenTyVar ieqs fsk)
; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk
, ppr eqns ])
; mapM_ (unifyDerived loc Nominal) eqns }
where
loc = ctEvLoc ev  ToDo: this location is wrong; it should be FunDepOrigin2
 See Trac #14778
improve_top_fun_eqs :: FamInstEnvs
> TyCon > [TcType] > TcType
> TcS [TypeEqn]
improve_top_fun_eqs fam_envs fam_tc args rhs_ty
 Just ops < isBuiltInSynFamTyCon_maybe fam_tc
= return (sfInteractTop ops args rhs_ty)
 see Note [Type inference for type families with injectivity]
 isOpenTypeFamilyTyCon fam_tc
, Injective injective_args < tyConInjectivityInfo fam_tc
, let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
=  it is possible to have several compatible equations in an open type
 family but we only want to derive equalities from one such equation.
do { let improvs = buildImprovementData fam_insts
fi_tvs fi_tys fi_rhs (const Nothing)
; traceTcS "improve_top_fun_eqs2" (ppr improvs)
; concatMapM (injImproveEqns injective_args) $
take 1 improvs }
 Just ax < isClosedSynFamilyTyConWithAxiom_maybe fam_tc
, Injective injective_args < tyConInjectivityInfo fam_tc
= concatMapM (injImproveEqns injective_args) $
buildImprovementData (fromBranches (co_ax_branches ax))
cab_tvs cab_lhs cab_rhs Just
 otherwise
= return []
where
buildImprovementData
:: [a]  axioms for a TF (FamInst or CoAxBranch)
> (a > [TyVar])  get bound tyvars of an axiom
> (a > [Type])  get LHS of an axiom
> (a > Type)  get RHS of an axiom
> (a > Maybe CoAxBranch)  Just => apartness check required
> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]
 Result:
 ( [arguments of a matching axiom]
 , RHSunifying substitution
 , axiom variables without substitution
 , Maybe matching axiom [Nothing  open TF, Just  closed TF ] )
buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
[ (ax_args, subst, unsubstTvs, wrap axiom)
 axiom < axioms
, let ax_args = axiomLHS axiom
ax_rhs = axiomRHS axiom
ax_tvs = axiomTVs axiom
, Just subst < [tcUnifyTyWithTFs False ax_rhs rhs_ty]
, let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ]
 The order of unsubstTvs is important; it must be
 in telescope order e.g. (k:*) (a:k)
injImproveEqns :: [Bool]
> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)
> TcS [TypeEqn]
injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
= do { subst < instFlexiX subst unsubstTvs
 If the current substitution bind [k > *], and
 one of the unsubstituted tyvars is (a::k), we'd better
 be sure to apply the current substitution to a's kind.
 Hence instFlexiX. Trac #13135 was an example.
; return [ Pair (substTyUnchecked subst ax_arg) arg
 NB: the ax_arg part is on the left
 see Note [Improvement orientation]
 case cabr of
Just cabr' > apartnessCheck (substTys subst ax_args) cabr'
_ > True
, (ax_arg, arg, True) < zip3 ax_args args inj_args ] }
shortCutReduction :: CtEvidence > TcTyVar > TcCoercion
 > TyCon > [TcType] > TcS (StopOrContinue Ct)
+ > TyCon > [TcType] > TcS ()
 See Note [Toplevel 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)
 ax_co :: F args ~ G tc_args
 old_ev :: F args ~ fsk
do { new_ev < case ctEvFlavour old_ev of
Given > newGivenEvVar deeper_loc
( 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 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 = tc_args, cc_fsk = fsk }
 ; updWorkListTcS (extendWorkListFunEq new_ct)
 ; stopWith old_ev "Fun/Top (shortcut)" }
+ ; updWorkListTcS (extendWorkListFunEq new_ct) }
where
deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
{ Note [Toplevel reductions for type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c.f. Note [The flattening story] in TcFlatten
Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom.
Here is what we do, in four cases:
* Wanteds: general firing rule
(work item) [W] x : F tys ~ fmv
instantiate axiom: ax_co : F tys ~ rhs
Then:
Discharge fmv := rhs
Discharge x := ax_co ; sym x2
This is *the* way that fmv's get unified; even though they are
"untouchable".
NB: Given Note [FunEq occurscheck principle], fmv does not appear
in tys, and hence does not appear in the instantiated RHS. So
the unification can't make an infinite type.
* Wanteds: short cut firing rule
Applies when the RHS of the axiom is another typefunction application
(work item) [W] x : F tys ~ fmv
instantiate axiom: ax_co : F tys ~ G rhs_tys
It would be a waste to create yet another fmv for (G rhs_tys).
Instead (shortCutReduction):
 Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
 Add G rhs_xis ~ fmv to flat cache (note: the same old fmv)
 New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan)
 Discharge x := ax_co ; G cos ; x2
* Givens: general firing rule
(work item) [G] g : F tys ~ fsk
instantiate axiom: ax_co : F tys ~ rhs
Now add noncanonical given (since rhs is not flat)
[G] (sym g ; ax_co) : fsk ~ rhs (Noncanonical)
* Givens: short cut firing rule
Applies when the RHS of the axiom is another typefunction application
(work item) [G] g : F tys ~ fsk
instantiate axiom: ax_co : F tys ~ G rhs_tys
It would be a waste to create yet another fsk for (G rhs_tys).
Instead (shortCutReduction):
 Flatten rhs_tys: flat_cos : tys ~ flat_tys
 Add new Canonical given
[G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan)
Note [FunEq occurscheck principle]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I have spent a lot of time finding a good way to deal with
CFunEqCan constraints like
F (fuv, a) ~ fuv
where flattenskolem occurs on the LHS. Now in principle we
might may progress by doing a reduction, but in practice its
hard to find examples where it is useful, and easy to find examples
where we fall into an infinite reduction loop. A rule that works
very well is this:
*** FunEq occurscheck principle ***
Do not reduce a CFunEqCan
F tys ~ fsk
if fsk appears free in tys
Instead we treat it as stuck.
Examples:
* Trac #5837 has [G] a ~ TF (a,Int), with an instance
type instance TF (a,b) = (TF a, TF b)
This readily loops when solving givens. But with the FunEq occurs
check principle, it rapidly gets stuck which is fine.
* Trac #12444 is a good example, explained in comment:2. We have
type instance F (Succ x) = Succ (F x)
[W] alpha ~ Succ (F alpha)
If we allow the reduction to happen, we get an infinite loop
Note [Cached solved FunEqs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
When trying to solve, say (FunExpensive bigtype ~ ty), it's important
to see if we have reduced (FunExpensive bigtype) before, lest we
simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover
we must use `funEqCanDischarge` because both uses might (say) be Wanteds,
and we *still* want to save the recomputation.
Note [MATCHINGSYNONYMS]
~~~~~~~~~~~~~~~~~~~~~~~~
When trying to match a dictionary (D tau) to a toplevel instance, or a
type family equation (F taus_1 ~ tau_2) to a toplevel family instance,
we do *not* need to expand type synonyms because the matcher will do that for us.
Note [Improvement orientation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A very delicate point is the orientation of derived equalities
arising from injectivity improvement (Trac #12522). Suppse we have
type family F x = t  t > x
type instance F (a, Int) = (Int, G a)
where G is injective; and wanted constraints
[W] TF (alpha, beta) ~ fuv
[W] fuv ~ (Int, )
The injectivity will give rise to derived constraints
[D] gamma1 ~ alpha
[D] Int ~ beta
The fresh unification variable gamma1 comes from the fact that we
can only do "partial improvement" here; see Section 5.2 of
"Injective type families for Haskell" (HS'15).
Now, it's very important to orient the equations this way round,
so that the fresh unification variable will be eliminated in
favour of alpha. If we instead had
[D] alpha ~ gamma1
then we would unify alpha := gamma1; and kick out the wanted
constraint. But when we grough it back in, it'd look like
[W] TF (gamma1, beta) ~ fuv
and exactly the same thing would happen again! Infinite loop.
This all seems fragile, and it might seem more robust to avoid
introducing gamma1 in the first place, in the case where the
actual argument (alpha, beta) partly matches the improvement
template. But that's a bit tricky, esp when we remember that the
kinds much match too; so it's easier to let the normal machinery
handle it. Instead we are careful to orient the new derived
equality with the template on the left. Delicate, but it works.
Note [No FunEq improvement for Givens]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't do improvements (injectivity etc) for Givens. Why?
* It generates Derived constraints on skolems, which don't do us
much good, except perhaps identify inaccessible branches.
(They'd be perfectly valid though.)
* For typenat stuff the derived constraints include type families;
e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this,
we'll generate a Derived/Wanted CFunEqCan; and, since the same
InertCans (after solving Givens) are used for each iteration, that
massively confused the unflattening step (TcFlatten.unflatten).
In fact it led to some infinite loops:
indexedtypes/should_compile/T10806
indexedtypes/should_compile/T10507
polykinds/T10742
Note [Reduction for Derived CFunEqCans]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You may wonder if it's important to use toplevel instances to
simplify [D] CFunEqCan's. But it is. Here's an example (T10226).
type instance F Int = Int
type instance FInv Int = Int
Suppose we have to solve
[WD] FInv (F alpha) ~ alpha
[WD] F alpha ~ Int
> flatten
[WD] F alpha ~ fuv0
[WD] FInv fuv0 ~ fuv1  (A)
[WD] fuv1 ~ alpha
[WD] fuv0 ~ Int  (B)
> Rewwrite (A) with (B), splitting it
[WD] F alpha ~ fuv0
[W] FInv fuv0 ~ fuv1
[D] FInv Int ~ fuv1  (C)
[WD] fuv1 ~ alpha
[WD] fuv0 ~ Int
> Reduce (C) with toplevel instance
**** This is the key step ***
[WD] F alpha ~ fuv0
[W] FInv fuv0 ~ fuv1
[D] fuv1 ~ Int  (D)
[WD] fuv1 ~ alpha  (E)
[WD] fuv0 ~ Int
> Rewrite (D) with (E)
[WD] F alpha ~ fuv0
[W] FInv fuv0 ~ fuv1
[D] alpha ~ Int  (F)
[WD] fuv1 ~ alpha
[WD] fuv0 ~ Int
> unify (F) alpha := Int, and that solves it
Another example is indexedtypes/should_compile/T10634
}
{ *******************************************************************
* *
Toplevel reaction for class constraints (CDictCan)
* *
**********************************************************************}
doTopReactDict :: InertSet > Ct > TcS (StopOrContinue Ct)
 Try to use typeclass instance declarations to simplify the constraint
doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
, cc_tyargs = xis })
 isGiven fl  Never use instances for Given constraints
= do { try_fundep_improvement
; continueWith work_item }
 Just ev < lookupSolvedDict inerts dict_loc cls xis  Cached
= do { setEvBindIfWanted fl (ctEvExpr ev)
; stopWith fl "Dict/Top (cached)" }
 otherwise  Wanted or Derived, but not cached
= do { dflags < getDynFlags
; lkup_inst_res < matchClassInst dflags inerts cls xis dict_loc
; case lkup_inst_res of
GenInst { lir_new_theta = theta
, lir_mk_ev = mk_ev
, lir_safe_over = s } >
do { traceTcS "doTopReact/found instance for" $ ppr fl
; checkReductionDepth deeper_loc dict_pred
; unless s $ insertSafeOverlapFailureTcS work_item
; if isDerived fl then finish_derived theta
else finish_wanted theta mk_ev }
NoInstance >
do { when (isImprovable fl) $
try_fundep_improvement
; continueWith work_item } }
where
dict_pred = mkClassPred cls xis
dict_loc = ctEvLoc fl
dict_origin = ctLocOrigin dict_loc
deeper_loc = zap_origin (bumpCtLocDepth dict_loc)
zap_origin loc  After applying an instance we can set ScOrigin to
 infinity, so that prohibitedSuperClassSolve never fires
 ScOrigin {} < dict_origin
= setCtLocOrigin loc (ScOrigin infinity)
 otherwise
= loc
finish_wanted :: [TcPredType]
> ([EvExpr] > EvTerm) > TcS (StopOrContinue Ct)
 Precondition: evidence term matches the predicate workItem
finish_wanted theta mk_ev
= do { addSolvedDict fl cls xis
; evc_vars < mapM (newWanted deeper_loc) theta
; setWantedEvBind (ctEvEvId fl) (mk_ev (map getEvExpr evc_vars))
; emitWorkNC (freshGoals evc_vars)
; stopWith fl "Dict/Top (solved wanted)" }
finish_derived theta  Use typeclass instances for Deriveds, in the hope
=  of generating some improvements
 C.f. Example 3 of Note [The improvement story]
 It's easy because no evidence is involved
do { emitNewDeriveds deeper_loc theta
; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))
; stopWith fl "Dict/Top (solved derived)" }
 We didn't solve it; so try functional dependencies with
 the instance environment, and return
 See also Note [Weird fundeps]
try_fundep_improvement
= do { traceTcS "try_fundeps" (ppr work_item)
; instEnvs < getInstEnvs
; emitFunDepDeriveds $
improveFromInstEnv instEnvs mk_ct_loc dict_pred }
mk_ct_loc :: PredType  From instance decl
> SrcSpan  also from instance deol
> CtLoc
mk_ct_loc inst_pred inst_loc
= dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
inst_pred inst_loc }
doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
{ *******************************************************************
* *
Class lookup
* *
**********************************************************************}
  Indicates if Instance met the Safe Haskell overlapping instances safety
 check.

 See Note [Safe Haskell Overlapping Instances] in TcSimplify
 See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
type SafeOverlapping = Bool
data LookupInstResult
= NoInstance
 GenInst { lir_new_theta :: [TcPredType]
, lir_mk_ev :: [EvExpr] > EvTerm
, lir_safe_over :: SafeOverlapping }
instance Outputable LookupInstResult where
ppr NoInstance = text "NoInstance"
ppr (GenInst { lir_new_theta = ev
, lir_safe_over = s })
= text "GenInst" <+> vcat [ppr ev, ss]
where ss = text $ if s then "[safe]" else "[unsafe]"
matchClassInst :: DynFlags > InertSet > Class > [Type] > CtLoc > TcS LookupInstResult
matchClassInst dflags inerts clas tys loc
 First check whether there is an inscope Given that could
 match this constraint. In that case, do not use toplevel
 instances. See Note [Instance and Given overlap]
 not (xopt LangExt.IncoherentInstances dflags)
, not (naturallyCoherentClass clas)
, let matchable_givens = matchableGivens loc pred inerts
, not (isEmptyBag matchable_givens)
= do { traceTcS "Delaying instance application" $
vcat [ text "Work item=" <+> pprClassPred clas tys
, text "Potential matching givens:" <+> ppr matchable_givens ]
; return NoInstance }
where
pred = mkClassPred clas tys
matchClassInst dflags _ clas tys loc
= do { traceTcS "matchClassInst" $ text "pred =" <+> ppr (mkClassPred clas tys) <+> char '{'
; res < match_class_inst dflags False clas tys loc
; traceTcS "} matchClassInst result" $ ppr res
; return res }
match_class_inst :: DynFlags
> Bool  True <=> caller is the shortcut solver
 See Note [Shortcut solving: overlap]
> Class > [Type] > CtLoc > TcS LookupInstResult
match_class_inst dflags short_cut clas tys loc
 cls_name == knownNatClassName = matchKnownNat clas tys
 cls_name == knownSymbolClassName = matchKnownSymbol clas tys
 isCTupleClass clas = matchCTuple clas tys
 cls_name == typeableClassName = matchTypeable clas tys
 clas `hasKey` heqTyConKey = matchLiftedEquality tys
 clas `hasKey` coercibleTyConKey = matchLiftedCoercible tys
 cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys loc
 otherwise = matchInstEnv dflags short_cut clas tys loc
where
cls_name = className clas
  If a class is "naturally coherent", then we needn't worry at all, in any
 way, about overlapping/incoherent instances. Just solve the thing!
 See Note [Naturally coherent classes]
 See also Note [The equality class story] in TysPrim.
naturallyCoherentClass :: Class > Bool
naturallyCoherentClass cls
= isCTupleClass cls
 cls `hasKey` heqTyConKey
 cls `hasKey` eqTyConKey
 cls `hasKey` coercibleTyConKey
{ Note [Instance and Given overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example, from the OutsideIn(X) paper:
instance P x => Q [x]
instance (x ~ y) => R y [x]
wob :: forall a b. (Q [b], R b a) => a > Int
g :: forall a. Q [a] => [a] > Int
g x = wob x
From 'g' we get the impliation constraint:
forall a. Q [a] => (Q [beta], R beta [a])
If we react (Q [beta]) with its toplevel axiom, we end up with a
(P beta), which we have no way of discharging. On the other hand,
if we react R beta [a] with the toplevel we get (beta ~ a), which
is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
now solvable by the given Q [a].
The partial solution is that:
In matchClassInst (and thus in topReact), we return a matching
instance only when there is no Given in the inerts which is
unifiable to this particular dictionary.
We treat any metatyvar as "unifiable" for this purpose,
*including* untouchable ones. But not skolems like 'a' in
the implication constraint above.
The end effect is that, much as we do for overlapping instances, we
delay choosing a class instance if there is a possibility of another
instance OR a given to match our constraint later on. This fixes
Trac #4981 and #5002.
Other notes:
* The check is done *first*, so that it also covers classes
with builtin instance solving, such as
 constraint tuples
 natural numbers
 Typeable
* Flattenskolems: we do not treat a flattenskolem as unifiable
for this purpose.
E.g. f :: Eq (F a) => [a] > [a]
f xs = ....(xs==xs).....
Here we get [W] Eq [a], and we don't want to refrain from solving
it because of the given (Eq (F a)) constraint!
* The givenoverlap problem is arguably not easy to appear in practice
due to our aggressive prioritization of equality solving over other
constraints, but it is possible. I've added a test case in
typecheck/shouldcompile/GivenOverlapping.hs
* Another "live" example is Trac #10195; another is #10177.
* We ignore the overlap problem if XIncoherentInstances is in force:
see Trac #6002 for a workedout example where this makes a
difference.
* Moreover notice that our goals here are different than the goals of
the toplevel overlapping checks. There we are interested in
validating the following principle:
If we inline a function f at a site where the same global
instance environment is available as the instance environment at
the definition site of f then we should get the same behaviour.
But for the Given Overlap check our goal is just related to completeness of
constraint solving.
* The solution is only a partial one. Consider the above example with
g :: forall a. Q [a] => [a] > Int
g x = let v = wob x
in v
and suppose we have XNoMonoLocalBinds, so that we attempt to find the most
general type for 'v'. When generalising v's type we'll simplify its
Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
will use the instance declaration after all. Trac #11948 was a case
in point.
All of this is disgustingly delicate, so to discourage people from writing
simplifiable class givens, we warn about signatures that contain them;
see TcValidity Note [Simplifiable given constraints].
Note [Naturally coherent classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A few builtin classes are "naturally coherent". This term means that
the "instance" for the class is bidirectional with its superclass(es).
For example, consider (~~), which behaves as if it was defined like
this:
class a ~# b => a ~~ b
instance a ~# b => a ~~ b
(See Note [The equality types story] in TysPrim.)
Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
without worrying about Note [Instance and Given overlap]. Why? Because
if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
so the reduction of the [W] constraint does not risk losing any solutions.
On the other hand, it can be fatal to /fail/ to reduce such
equalities, on the grounds of Note [Instance and Given overlap],
because many good things flow from [W] t1 ~# t2.
The same reasoning applies to
* (~~) heqTyCOn
* (~) eqTyCon
* Coercible coercibleTyCon
And less obviously to:
* Tuple classes. For reasons described in TcSMonad
Note [Tuples hiding implicit parameters], we may have a constraint
[W] (?x::Int, C a)
with an exactlymatching Given constraint. We must decompose this
tuple and solve the components separately, otherwise we won't solve
it at all! It is perfectly safe to decompose it, because again the
superclasses invert the instance; e.g.
class (c1, c2) => (% c1, c2 %)
instance (c1, c2) => (% c1, c2 %)
Example in Trac #14218
Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b
PS: the term "naturally coherent" doesn't really seem helpful.
Perhaps "invertible" or something? I left it for now though.
}
{ *******************************************************************
* *
Class lookup in the instance environment
* *
**********************************************************************}
matchInstEnv :: DynFlags > Bool > Class > [Type] > CtLoc > TcS LookupInstResult
matchInstEnv dflags short_cut_solver clas tys loc
= do { instEnvs < getInstEnvs
; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
(matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
; case (matches, unify, safeHaskFail) of
 Nothing matches
([], _, _)
> do { traceTcS "matchClass not matching" (ppr pred)
; return NoInstance }
 A single match (& no safe haskell failure)
([(ispec, inst_tys)], [], False)
 short_cut_solver
, isOverlappable ispec
 If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
 then don't let the shortcut solver choose it, because a
 later instance might overlap it. Trac #14434 is an example
 See Note [Shortcut solving: overlap]
> do { traceTcS "matchClass: ingnoring overlappable" (ppr pred)
; return NoInstance }
 otherwise
> do { let dfun_id = instanceDFunId ispec
; traceTcS "matchClass success" $
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
 Record that this dfun is needed
; match_one (null unsafeOverlaps) dfun_id inst_tys }
 More than one matches (or Safe Haskell fail!). Defer any
 reactions of a multitude until we learn more about the reagent
(matches, _, _)
> do { traceTcS "matchClass multiple matches, deferring choice" $
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches]
; return NoInstance } }
where
pred = mkClassPred clas tys
match_one :: SafeOverlapping > DFunId > [DFunInstType] > TcS LookupInstResult
 See Note [DFunInstType: instantiating types] in InstEnv
match_one so dfun_id mb_inst_tys
= do { checkWellStagedDFun pred dfun_id loc
; (tys, theta) < instDFunType dfun_id mb_inst_tys
; return $ GenInst { lir_new_theta = theta
, lir_mk_ev = EvExpr . evDFunApp dfun_id tys
, lir_safe_over = so } }
{ ********************************************************************
* *
Class lookup for CTuples
* *
***********************************************************************}
matchCTuple :: Class > [Type] > TcS LookupInstResult
matchCTuple clas tys  (isCTupleClass clas) holds
= return (GenInst { lir_new_theta = tys
, lir_mk_ev = tuple_ev
, lir_safe_over = True })
 The dfun *is* the data constructor!
where
data_con = tyConSingleDataCon (classTyCon clas)
tuple_ev = EvExpr . evDFunApp (dataConWrapId data_con) tys
{ ********************************************************************
* *
Class lookup for Literals
* *
***********************************************************************}
{
Note [KnownNat & KnownSymbol and EvLit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A part of the typelevel literals implementation are the classes
"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
defining singleton values. Here is the key stuff from GHC.TypeLits
class KnownNat (n :: Nat) where
natSing :: SNat n
newtype SNat (n :: Nat) = SNat Integer
Conceptually, this class has infinitely many instances:
instance KnownNat 0 where natSing = SNat 0
instance KnownNat 1 where natSing = SNat 1
instance KnownNat 2 where natSing = SNat 2
...
In practice, we solve `KnownNat` predicates in the typechecker
(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
We make the following assumptions about dictionaries in GHC:
1. The "dictionary" for classes with a single methodlike `KnownNat`is
a newtype for the type of the method, so using a evidence amounts
to a coercion, and
2. Newtypes use the same representation as their definition types.
So, the evidence for `KnownNat` is just a value of the representation type,
wrapped in two newtype constructors: one to make it into a `SNat` value,
and another to make it into a `KnownNat` dictionary.
Also note that `natSing` and `SNat` are never actually exposed from the
librarythey are just an implementation detail. Instead, users see
a more convenient function, defined in terms of `natSing`:
natVal :: KnownNat n => proxy n > Integer
The reason we don't use this directly in the class is that it is simpler
and more efficient to pass around an integer rather than an entire function,
especially when the `KnowNat` evidence is packaged up in an existential.
The story for kind `Symbol` is analogous:
* class KnownSymbol
* newtype SSymbol
* Evidence: a Core literal (e.g. mkNaturalExpr)
}
matchKnownNat :: Class > [Type] > TcS LookupInstResult
matchKnownNat clas [ty]  clas = KnownNat
 Just n < isNumLitTy ty = do
et < mkNaturalExpr n
makeLitDict clas ty et
matchKnownNat _ _ = return NoInstance
matchKnownSymbol :: Class > [Type] > TcS LookupInstResult
matchKnownSymbol clas [ty]  clas = KnownSymbol
 Just s < isStrLitTy ty = do
et < mkStringExprFS s
makeLitDict clas ty et
matchKnownSymbol _ _ = return NoInstance
makeLitDict :: Class > Type > EvExpr > TcS LookupInstResult
 makeLitDict adds a coercion that will convert the literal into a dictionary
 of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]
 in TcEvidence. The coercion happens in 2 steps:

 Integer > SNat n  representation of literal to singleton
 SNat n > KnownNat n  singleton to dictionary

 The process is mirrored for Symbols:
 String > SSymbol n
 SSymbol n > KnownSymbol n
makeLitDict clas ty et
 Just (_, co_dict) < tcInstNewTyCon_maybe (classTyCon clas) [ty]
 co_dict :: KnownNat n ~ SNat n
, [ meth ] < classMethods clas
, Just tcRep < tyConAppTyCon_maybe  SNat
$ funResultTy  SNat n
$ dropForAlls  KnownNat n => SNat n
$ idType meth  forall n. KnownNat n => SNat n
, Just (_, co_rep) < tcInstNewTyCon_maybe tcRep [ty]
 SNat n ~ Integer
, let ev_tm = EvExpr $ mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
= return $ GenInst { lir_new_theta = []
, lir_mk_ev = \_ > ev_tm
, lir_safe_over = True }
 otherwise
= panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
$$ vcat (map (ppr . idType) (classMethods clas)))
{ ********************************************************************
* *
Class lookup for Typeable
* *
***********************************************************************}
  Assumes that we've checked that this is the 'Typeable' class,
 and it was applied to the correct argument.
matchTypeable :: Class > [Type] > TcS LookupInstResult
matchTypeable clas [k,t]  clas = Typeable
 For the first two cases, See Note [No Typeable for polytypes or qualified types]
 isForAllTy k = return NoInstance  Polytype
 isJust (tcSplitPredFunTy_maybe t) = return NoInstance  Qualified type
 Now cases that do work
 k `eqType` typeNatKind = doTyLit knownNatClassName t
 k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t
 isConstraintKind t = doTyConApp clas t constraintKindTyCon []
 Just (arg,ret) < splitFunTy_maybe t = doFunTy clas t arg ret
 Just (tc, ks) < splitTyConApp_maybe t  See Note [Typeable (T a b c)]
, onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks
 Just (f,kt) < splitAppTy_maybe t = doTyApp clas t f kt
matchTypeable _ _ = return NoInstance
  Representation for a type @ty@ of the form @arg > ret@.
doFunTy :: Class > Type > Type > Type > TcS LookupInstResult
doFunTy clas ty arg_ty ret_ty
= do { let preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]
build_ev [arg_ev, ret_ev] =
evTypeable ty $ EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev)
build_ev _ = panic "TcInteract.doFunTy"
; return $ GenInst preds build_ev True
}
  Representation for type constructor applied to some kinds.
 'onlyNamedBndrsApplied' has ensured that this application results in a type
 of monomorphic kind (e.g. all kind variables have been instantiated).
doTyConApp :: Class > Type > TyCon > [Kind] > TcS LookupInstResult
doTyConApp clas ty tc kind_args
 Just _ < tyConRepName_maybe tc
= return $ GenInst (map (mk_typeable_pred clas) kind_args)
(\kinds > evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds))
True
 otherwise
= return NoInstance
  Representation for TyCon applications of a concrete kind. We just use the
 kind itself, but first we must make sure that we've instantiated all kind
 polymorphism, but no more.
onlyNamedBndrsApplied :: TyCon > [KindOrType] > Bool
onlyNamedBndrsApplied tc ks
= all isNamedTyConBinder used_bndrs &&
not (any isNamedTyConBinder leftover_bndrs)
where
bndrs = tyConBinders tc
(used_bndrs, leftover_bndrs) = splitAtList ks bndrs
doTyApp :: Class > Type > Type > KindOrType > TcS LookupInstResult
 Representation for an application of a type to a typeorkind.
 This may happen when the type expression starts with a type variable.
 Example (ignoring kind parameter):
 Typeable (f Int Char) >
 (Typeable (f Int), Typeable Char) >
 (Typeable f, Typeable Int, Typeable Char) > (after some simp. steps)
 Typeable f
doTyApp clas ty f tk
 isForAllTy (typeKind f)
= return NoInstance  We can't solve until we know the ctr.
 otherwise
= return $ GenInst (map (mk_typeable_pred clas) [f, tk])
(\[t1,t2] > evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2))
True
 Emit a `Typeable` constraint for the given type.
mk_typeable_pred :: Class > Type > PredType
mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
 Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
 we generate a subgoal for the appropriate class. See #10348 for what
 happens when we fail to do this.
doTyLit :: Name > Type > TcS LookupInstResult
doTyLit kc t = do { kc_clas < tcLookupClass kc
; let kc_pred = mkClassPred kc_clas [ t ]
mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)
mk_ev _ = panic "doTyLit"
; return (GenInst [kc_pred] mk_ev True) }
{ Note [Typeable (T a b c)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For type applications we always decompose using binary application,
via doTyApp, until we get to a *kind* instantiation. Example
Proxy :: forall k. k > *
To solve Typeable (Proxy (* > *) Maybe) we
 First decompose with doTyApp,
to get (Typeable (Proxy (* > *))) and Typeable Maybe
 Then solve (Typeable (Proxy (* > *))) with doTyConApp
If we attempt to shortcut by solving it all at once, via
doTyConApp
(this note is sadly truncated FIXME)
Note [No Typeable for polytypes or qualified types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not support impredicative typeable, such as
Typeable (forall a. a>a)
Typeable (Eq a => a > a)
Typeable (() => Int)
Typeable (((),()) => Int)
See Trac #9858. For forall's the case is clear: we simply don't have
a TypeRep for them. For qualified but not polymorphic types, like
(Eq a => a > a), things are murkier. But:
* We don't need a TypeRep for these things. TypeReps are for
monotypes only.
* Perhaps we could treat `=>` as another type constructor for `Typeable`
purposes, and thus support things like `Eq Int => Int`, however,
at the current state of affairs this would be an odd exception as
no other class works with impredicative types.
For now we leave it off, until we have a better story for impredicativity.
}
{ ********************************************************************
* *
Class lookup for lifted equality
* *
***********************************************************************}
 See also Note [The equality types story] in TysPrim
matchLiftedEquality :: [Type] > TcS LookupInstResult
matchLiftedEquality args
= return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ]
, lir_mk_ev = EvExpr . evDFunApp (dataConWrapId heqDataCon) args
, lir_safe_over = True })
 See also Note [The equality types story] in TysPrim
matchLiftedCoercible :: [Type] > TcS LookupInstResult
matchLiftedCoercible args@[k, t1, t2]
= return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
, lir_mk_ev = EvExpr . evDFunApp (dataConWrapId coercibleDataCon)
args
, lir_safe_over = True })
where
args' = [k, k, t1, t2]
matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
{ ********************************************************************
* *
Class lookup for overloaded record fields
* *
***********************************************************************}
{
Note [HasField instances]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
data T y = MkT { foo :: [y] }
and `foo` is in scope. Then GHC will automatically solve a constraint like
HasField "foo" (T Int) b
by emitting a new wanted
T alpha > [alpha] ~# T Int > b
and building a HasField dictionary out of the selector function `foo`,
appropriately cast.
The HasField class is defined (in GHC.Records) thus:
class HasField (x :: k) r a  x r > a where
getField :: r > a
Since this is a onemethod class, it is represented as a newtype.
Hence we can solve `HasField "foo" (T Int) b` by taking an expression
of type `T Int > b` and casting it using the newtype coercion.
Note that
foo :: forall y . T y > [y]
so the expression we construct is
foo @alpha > co
where
co :: (T alpha > [alpha]) ~# HasField "foo" (T Int) b
is built from
co1 :: (T alpha > [alpha]) ~# (T Int > b)
which is the new wanted, and
co2 :: (T Int > b) ~# HasField "foo" (T Int) b
which can be derived from the newtype coercion.
If `foo` is not in scope, or has a higherrank or existentially
quantified type, then the constraint is not solved automatically, but
may be solved by a usersupplied HasField instance. Similarly, if we
encounter a HasField constraint where the field is not a literal
string, or does not belong to the type, then we fall back on the
normal constraint solver behaviour.
}
 See Note [HasField instances]
matchHasField :: DynFlags > Bool > Class > [Type] > CtLoc > TcS LookupInstResult
matchHasField dflags short_cut clas tys loc
= do { fam_inst_envs < getFamInstEnvs
; rdr_env < getGlobalRdrEnvTcS
; case tys of
 We are matching HasField {k} x r a...
[_k_ty, x_ty, r_ty, a_ty]
 x should be a literal string
 Just x < isStrLitTy x_ty
 r should be an applied type constructor
, Just (tc, args) < tcSplitTyConApp_maybe r_ty
 use representation tycon (if data family); it has the fields
, let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
 x should be a field of r
, Just fl < lookupTyConFieldLabel x r_tc
 the field selector should be in scope
, Just gre < lookupGRE_FieldLabel rdr_env fl
> do { sel_id < tcLookupId (flSelector fl)
; (tv_prs, preds, sel_ty) < tcInstType newMetaTyVars sel_id
 The first new wanted constraint equates the actual
 type of the selector with the type (r > a) within
 the HasField x r a dictionary. The preds will
 typically be empty, but if the datatype has a
 "stupid theta" then we have to include it here.
; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
 Use the equality proof to cast the selector Id to
 type (r > a), then use the newtype coercion to cast
 it to a HasField dictionary.
mk_ev (ev1:evs) = EvExpr $ evSelector sel_id tvs evs `evCast` co
where
co = mkTcSubCo (evTermCoercion (EvExpr ev1))
`mkTcTransCo` mkTcSymCo co2
mk_ev [] = panic "matchHasField.mk_ev"
Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
tys
tvs = mkTyVarTys (map snd tv_prs)
 The selector must not be "naughty" (i.e. the field
 cannot have an existentially quantified type), and
 it must not be higherrank.
; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
then do { addUsedGRE True gre
; return GenInst { lir_new_theta = theta
, lir_mk_ev = mk_ev
, lir_safe_over = True
} }
else matchInstEnv dflags short_cut clas tys loc }
_ > matchInstEnv dflags short_cut clas tys loc }
diff git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index f5d6ca9..d26275b 100644
 a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ 1,3343 +1,3353 @@
{# LANGUAGE CPP, TypeFamilies #}
 Type definitions for the constraint solver
module TcSMonad (
 The work list
WorkList(..), isEmptyWorkList, emptyWorkList,
extendWorkListNonEq, extendWorkListCt,
extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
appendWorkList, extendWorkListImplic,
selectNextWorkItem,
workListSize, workListWantedCount,
getWorkList, updWorkListTcS,
 The TcS monad
TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
failTcS, warnTcS, addErrTcS,
runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS, checkConstraintsTcS,
runTcPluginTcS, addUsedGRE, addUsedGREs,
 Tracing etc
panicTcS, traceTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
 Evidence creation and transformation
MaybeNew(..), freshGoals, isFresh, getEvExpr,
newTcEvBinds, newNoTcEvBinds,
newWantedEq, emitNewWantedEq,
newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,
newBoundEvVarId,
unifyTyVar, unflattenFmv, reportUnifications,
setEvBind, setWantedEq, setEqIfWanted,
setWantedEvTerm, setWantedEvBind, setEvBindIfWanted,
newEvVar, newGivenEvVar, newGivenEvVars,
emitNewDeriveds, emitNewDerivedEq,
checkReductionDepth,
getSolvedDicts, setSolvedDicts,
getInstEnvs, getFamInstEnvs,  Getting the environments
getTopEnv, getGblEnv, getLclEnv,
getTcEvBindsVar, getTcLevel,
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
tcLookupClass, tcLookupId,
 Inerts
InertSet(..), InertCans(..),
updInertTcS, updInertCans, updInertDicts, updInertIrreds,
getNoGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertGivens,
getInertInsols,
getTcSInerts, setTcSInerts,
matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts,
removeInertCts, getPendingScDicts,
addInertCan, addInertEq, insertFunEq,
emitWorkNC, emitWork,
isImprovable,
 The Model
kickOutAfterUnification,
 Inert Safe Haskell safeoverlap failures
addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
getSafeOverlapFailures,
 Inert CDictCans
DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
addDictsByClass, delDict, foldDicts, filterDicts, findDict,
 Inert CTyEqCans
EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
lookupFlattenTyVar, lookupInertTyVar,
 Inert solved dictionaries
addSolvedDict, lookupSolvedDict,
 Irreds
foldIrreds,
 The flattening cache
lookupFlatCache, extendFlatCache, newFlattenSkolem,  Flatten skolems
 dischargeFmv, pprKicked,
+ dischargeFunEq, pprKicked,
 Inert CFunEqCans
updInertFunEqs, findFunEq,
findFunEqsByTyCon,
instDFunType,  Instantiation
 MetaTyVars
newFlexiTcSTy, instFlexi, instFlexiX,
cloneMetaTyVar, demoteUnfilledFmv,
tcInstType, tcInstSkolTyVarsX,
TcLevel,
isFilledMetaTyVar_maybe, isFilledMetaTyVar,
zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
zonkTyCoVarsAndFVList,
zonkSimples, zonkWC,
zonkTcTyCoVarBndr,
 References
newTcRef, readTcRef, updTcRef,
 Misc
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
checkWellStagedDFun,
pprEq  Smaller utils, reexported from TcM
 TODO (DV): these are only really used in the
 instance matcher in TcSimplify. I am wondering
 if the whole instance matcher simply belongs
 here
) where
#include "HsVersions.h"
import GhcPrelude
import HscTypes
import qualified Inst as TcM
import InstEnv
import FamInst
import FamInstEnv
import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )
import PrelNames( heqTyConKey, eqTyConKey )
import Kind
import TcType
import DynFlags
import Type
import Coercion
import Unify
import TcEvidence
import Class
import TyCon
import TcErrors ( solverDepthErrorTcS )
import Name
import Module ( HasModule, getModule )
import RdrName ( GlobalRdrEnv, GlobalRdrElt )
import qualified RnEnv as TcM
import Var
import VarEnv
import VarSet
import Outputable
import Bag
import UniqSupply
import Util
import TcRnTypes
import Unique
import UniqFM
import UniqDFM
import Maybes
import CoreMap
import Control.Monad
import qualified Control.Monad.Fail as MonadFail
import MonadUtils
import Data.IORef
import Data.List ( foldl', partition )
#if defined(DEBUG)
import Digraph
import UniqSet
#endif
{
************************************************************************
* *
* Worklists *
* Canonical and noncanonical constraints that the simplifier has to *
* work on. Including their simplification depths. *
* *
* *
************************************************************************
Note [WorkList priorities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
A WorkList contains canonical and noncanonical items (of all flavors).
Notice that each Ct now has a simplification depth. We may
consider using this depth for prioritization as well in the future.
As a simple form of priority queue, our worklist separates out
* equalities (wl_eqs); see Note [Prioritise equalities]
* typefunction equalities (wl_funeqs)
* all the rest (wl_rest)
Note [Prioritise equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very important to process equalities /first/:
* (Efficiency) The general reason to do so is that if we process a
class constraint first, we may end up putting it into the inert set
and then kicking it out later. That's extra work compared to just
doing the equality first.
* (Avoiding fundep iteration) As Trac #14723 showed, it's possible to
get nontermination if we
 Emit the Derived fundep equalities for a class constraint,
generating some fresh unification variables.
 That leads to some unification
 Which kicks out the class constraint
 Which isn't solved (because there are still some more Derived
equalities in the worklist), but generates yet more fundeps
Solution: prioritise derived equalities over class constraints
* (Class equalities) We need to prioritise equalities even if they
are hidden inside a class constraint;
see Note [Prioritise class equalities]
* (Kickout) We want to apply this priority scheme to kickedout
constraints too (see the call to extendWorkListCt in kick_out_rewritable
E.g. a CIrredCan can be a heterokinded (t1 ~ t2), which may become
homokinded when kicked out, and hence we want to priotitise it.
* (Derived equalities) Originally we tried to postpone processing
Derived equalities, in the hope that we might never need to deal
with them at all; but in fact we must process Derived equalities
eagerly, partly for the (Efficiency) reason, and more importantly
for (Avoiding fundep iteration).
Note [Prioritise class equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We prioritise equalities in the solver (see selectWorkItem). But class
constraints like (a ~ b) and (a ~~ b) are actually equalities too;
see Note [The equality types story] in TysPrim.
Failing to prioritise these is inefficient (more kickouts etc).
But, worse, it can prevent us spotting a "recursive knot" among
Wanted constraints. See comment:10 of Trac #12734 for a workedout
example.
So we arrange to put these particular class constraints in the wl_eqs.
NB: since we do not currently apply the substitution to the
inert_solved_dicts, the knottying still seems a bit fragile.
But this makes it better.
}
 See Note [WorkList priorities]
data WorkList
= WL { wl_eqs :: [Ct]  CTyEqCan, CDictCan, CIrredCan
 Given, Wanted, and Derived
 Contains both equality constraints and their
 classlevel variants (a~b) and (a~~b);
 See Note [Prioritise equalities]
 See Note [Prioritise class equalities]
, wl_funeqs :: [Ct]
, wl_rest :: [Ct]
, wl_implics :: Bag Implication  See Note [Residual implications]
}
appendWorkList :: WorkList > WorkList > WorkList
appendWorkList
(WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
, wl_implics = implics1 })
(WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
, wl_implics = implics2 })
= WL { wl_eqs = eqs1 ++ eqs2
, wl_funeqs = funeqs1 ++ funeqs2
, wl_rest = rest1 ++ rest2
, wl_implics = implics1 `unionBags` implics2 }
workListSize :: WorkList > Int
workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
= length eqs + length funeqs + length rest
workListWantedCount :: WorkList > Int
 Count the things we need to solve
 excluding the insolubles (c.f. inert_count)
workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
= count isWantedCt eqs + count is_wanted rest
where
is_wanted ct
 CIrredCan { cc_ev = ev, cc_insol = insol } < ct
= not insol && isWanted ev
 otherwise
= isWantedCt ct
extendWorkListEq :: Ct > WorkList > WorkList
extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
extendWorkListFunEq :: Ct > WorkList > WorkList
extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
extendWorkListNonEq :: Ct > WorkList > WorkList
 Extension by non equality
extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
extendWorkListDeriveds :: [CtEvidence] > WorkList > WorkList
extendWorkListDeriveds evs wl
= extendWorkListCts (map mkNonCanonical evs) wl
extendWorkListImplic :: Bag Implication > WorkList > WorkList
extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }
extendWorkListCt :: Ct > WorkList > WorkList
 Agnostic
extendWorkListCt ct wl
= case classifyPredType (ctPred ct) of
EqPred NomEq ty1 _
 Just tc < tcTyConAppTyCon_maybe ty1
, isTypeFamilyTyCon tc
> extendWorkListFunEq ct wl
EqPred {}
> extendWorkListEq ct wl
ClassPred cls _  See Note [Prioritise class equalities]
 cls `hasKey` heqTyConKey
 cls `hasKey` eqTyConKey
> extendWorkListEq ct wl
_ > extendWorkListNonEq ct wl
extendWorkListCts :: [Ct] > WorkList > WorkList
 Agnostic
extendWorkListCts cts wl = foldr extendWorkListCt wl cts
isEmptyWorkList :: WorkList > Bool
isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
, wl_rest = rest, wl_implics = implics })
= null eqs && null rest && null funeqs && isEmptyBag implics
emptyWorkList :: WorkList
emptyWorkList = WL { wl_eqs = [], wl_rest = []
, wl_funeqs = [], wl_implics = emptyBag }
selectWorkItem :: WorkList > Maybe (Ct, WorkList)
 See Note [Prioritise equalities]
selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
, wl_rest = rest })
 ct:cts < eqs = Just (ct, wl { wl_eqs = cts })
 ct:fes < feqs = Just (ct, wl { wl_funeqs = fes })
 ct:cts < rest = Just (ct, wl { wl_rest = cts })
 otherwise = Nothing
getWorkList :: TcS WorkList
getWorkList = do { wl_var < getTcSWorkListRef
; wrapTcS (TcM.readTcRef wl_var) }
selectNextWorkItem :: TcS (Maybe Ct)
 Pick which work item to do next
 See Note [Prioritise equalities]
selectNextWorkItem
= do { wl_var < getTcSWorkListRef
; wl < wrapTcS (TcM.readTcRef wl_var)
; case selectWorkItem wl of {
Nothing > return Nothing ;
Just (ct, new_wl) >
do { checkReductionDepth (ctLoc ct) (ctPred ct)
; wrapTcS (TcM.writeTcRef wl_var new_wl)
; return (Just ct) } } }
 Pretty printing
instance Outputable WorkList where
ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
, wl_rest = rest, wl_implics = implics })
= text "WL" <+> (braces $
vcat [ ppUnless (null eqs) $
text "Eqs =" <+> vcat (map ppr eqs)
, ppUnless (null feqs) $
text "Funeqs =" <+> vcat (map ppr feqs)
, ppUnless (null rest) $
text "Noneqs =" <+> vcat (map ppr rest)
, ppUnless (isEmptyBag implics) $
ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))
(text "(Implics omitted)")
])
{ *********************************************************************
* *
InertSet: the inert set
* *
* *
********************************************************************* }
data InertSet
= IS { inert_cans :: InertCans
 Canonical Given, Wanted, Derived
 Sometimes called "the inert set"
, inert_fsks :: [(TcTyVar, TcType)]
 A list of (fsk, ty) pairs; we add one element when we flatten
 a function application in a Given constraint, creating
 a new fsk in newFlattenSkolem. When leaving a nested scope,
 unflattenGivens unifies fsk := ty

 We could also get this info from inert_funeqs, filtered by
 level, but it seems simpler and more direct to capture the
 fsk as we generate them.
, inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
 See Note [Type family equations]
 If F tys :> (co, rhs, flav),
 then co :: F tys ~ rhs
 flav is [G] or [WD]

 Just a hashcons cache for use when flattening only
 These include entirely unprocessed goals, so don't use
 them to solve a toplevel goal, else you may end up solving
 (w:F ty ~ a) by setting w:=w! We just use the flatcache
 when allocating a new flattenskolem.
 Not necessarily inert wrt toplevel equations (or inert_cans)
 NB: An ExactFunEqMap  this doesn't match via loose types!
, inert_solved_dicts :: DictMap CtEvidence
 All Wanteds, of form ev :: C t1 .. tn
 See Note [Solved dictionaries]
 and Note [Do not add superclasses of solved dictionaries]
}
instance Outputable InertSet where
ppr (IS { inert_cans = ics
, inert_fsks = ifsks
, inert_solved_dicts = solved_dicts })
= vcat [ ppr ics
, text "Inert fsks =" <+> ppr ifsks
, ppUnless (null dicts) $
text "Solved dicts =" <+> vcat (map ppr dicts) ]
where
dicts = bagToList (dictsToBag solved_dicts)
emptyInert :: InertSet
emptyInert
= IS { inert_cans = IC { inert_count = 0
, inert_eqs = emptyDVarEnv
, inert_dicts = emptyDicts
, inert_safehask = emptyDicts
, inert_funeqs = emptyFunEqs
, inert_irreds = emptyCts }
, inert_flat_cache = emptyExactFunEqs
, inert_fsks = []
, inert_solved_dicts = emptyDictMap }
{ Note [Solved dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we apply a toplevel instance declaration, we add the "solved"
dictionary to the inert_solved_dicts. In general, we use it to avoid
creating a new EvVar when we have a new goal that we have solved in
the past.
But in particular, we can use it to create *recursive* dictionaries.
The simplest, degnerate case is
instance C [a] => C [a] where ...
If we have
[W] d1 :: C [x]
then we can apply the instance to get
d1 = $dfCList d
[W] d2 :: C [x]
Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.
d1 = $dfCList d
d2 = d1
See Note [Example of recursive dictionaries]
Other notes about solved dictionaries
* See also Note [Do not add superclasses of solved dictionaries]
* The inert_solved_dicts field is not rewritten by equalities,
so it may get out of date.
* THe inert_solved_dicts are all Wanteds, never givens
Note [Do not add superclasses of solved dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Every member of inert_solved_dicts is the result of applying a dictionary
function, NOT of applying superclass selection to anything.
Consider
class Ord a => C a where
instance Ord [a] => C [a] where ...
Suppose we are trying to solve
[G] d1 : Ord a
[W] d2 : C [a]
Then we'll use the instance decl to give
[G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3
[W] d3 : Ord [a]
We must not add d4 : Ord [a] to the 'solved' set (by taking the
superclass of d2), otherwise we'll use it to solve d3, without ever
using d1, which would be a catastrophe.
Solution: when extending the solved dictionaries, do not add superclasses.
That's why each element of the inert_solved_dicts is the result of applying
a dictionary function.
Note [Example of recursive dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Example 1
data D r = ZeroD  SuccD (r (D r));
instance (Eq (r (D r))) => Eq (D r) where
ZeroD == ZeroD = True
(SuccD a) == (SuccD b) = a == b
_ == _ = False;
equalDC :: D [] > D [] > Bool;
equalDC = (==);
We need to prove (Eq (D [])). Here's how we go:
[W] d1 : Eq (D [])
By instance decl of Eq (D r):
[W] d2 : Eq [D []] where d1 = dfEqD d2
By instance decl of Eq [a]:
[W] d3 : Eq (D []) where d2 = dfEqList d3
d1 = dfEqD d2
Now this wanted can interact with our "solved" d1 to get:
d3 = d1
 Example 2:
This code arises in the context of "Scrap Your Boilerplate with Class"
class Sat a
class Data ctx a
instance Sat (ctx Char) => Data ctx Char  dfunData1
instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]  dfunData2
class Data Maybe a => Foo a
instance Foo t => Sat (Maybe t)  dfunSat
instance Data Maybe a => Foo a  dfunFoo1
instance Foo a => Foo [a]  dfunFoo2
instance Foo [Char]  dfunFoo3
Consider generating the superclasses of the instance declaration
instance Foo a => Foo [a]
So our problem is this
[G] d0 : Foo t
[W] d1 : Data Maybe [t]  Desired superclass
We may add the given in the inert set, along with its superclasses
Inert:
[G] d0 : Foo t
[G] d01 : Data Maybe t  Superclass of d0
WorkList
[W] d1 : Data Maybe [t]
Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3
Inert:
[G] d0 : Foo t
[G] d01 : Data Maybe t  Superclass of d0
Solved:
d1 : Data Maybe [t]
WorkList:
[W] d2 : Sat (Maybe [t])
[W] d3 : Data Maybe t
Now, we may simplify d2 using dfunSat; d2 := dfunSat d4
Inert:
[G] d0 : Foo t
[G] d01 : Data Maybe t  Superclass of d0
Solved:
d1 : Data Maybe [t]
d2 : Sat (Maybe [t])
WorkList:
[W] d3 : Data Maybe t
[W] d4 : Foo [t]
Now, we can just solve d3 from d01; d3 := d01
Inert
[G] d0 : Foo t
[G] d01 : Data Maybe t  Superclass of d0
Solved:
d1 : Data Maybe [t]
d2 : Sat (Maybe [t])
WorkList
[W] d4 : Foo [t]
Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5
Inert
[G] d0 : Foo t
[G] d01 : Data Maybe t  Superclass of d0
Solved:
d1 : Data Maybe [t]
d2 : Sat (Maybe [t])
d4 : Foo [t]
WorkList:
[W] d5 : Foo t
Now, d5 can be solved! d5 := d0
Result
d1 := dfunData2 d2 d3
d2 := dfunSat d4
d3 := d01
d4 := dfunFoo2 d5
d5 := d0
}
{ *********************************************************************
* *
InertCans: the canonical inerts
* *
* *
********************************************************************* }
data InertCans  See Note [Detailed InertCans Invariants] for more
= IC { inert_eqs :: InertEqs
 See Note [inert_eqs: the inert equalities]
 All CTyEqCans; index is the LHS tyvar
 Domain = skolems and untouchables; a touchable would be unified
, inert_funeqs :: FunEqMap Ct
 All CFunEqCans; index is the whole family head type.
 All Nominal (that's an invarint of all CFunEqCans)
 LHS is fully rewritten (modulo eqCanRewrite constraints)
 wrt inert_eqs
 Can include all flavours, [G], [W], [WD], [D]
 See Note [Type family equations]
, inert_dicts :: DictMap Ct
 Dictionaries only
 All fully rewritten (modulo flavour constraints)
 wrt inert_eqs
, inert_safehask :: DictMap Ct
 Failed dictionary resolution due to Safe Haskell overlapping
 instances restriction. We keep this separate from inert_dicts
 as it doesn't cause compilation failure, just safe inference
 failure.

 ^ See Note [Safe Haskell Overlapping Instances Implementation]
 in TcSimplify
, inert_irreds :: Cts
 Irreducible predicates that cannot be made canonical,
 and which don't interact with others (e.g. (c a))
 and insoluble predicates (e.g. Int ~ Bool, or a ~ [a])
, inert_count :: Int
 Number of Wanted goals in
 inert_eqs, inert_dicts, inert_safehask, inert_irreds
 Does not include insolubles
 When nonzero, keep trying to solve
}
type InertEqs = DTyVarEnv EqualCtList
type EqualCtList = [Ct]  See Note [EqualCtList invariants]
{ Note [Detailed InertCans Invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The InertCans represents a collection of constraints with the following properties:
* All canonical
* No two dictionaries with the same head
* No two CIrreds with the same type
* Family equations inert wrt toplevel family axioms
* Dictionaries have no matching toplevel instance
* Given family or dictionary constraints don't mention touchable
unification variables
* NonCTyEqCan constraints are fully rewritten with respect
to the CTyEqCan equalities (modulo canRewrite of course;
eg a wanted cannot rewrite a given)
* CTyEqCan equalities: see Note [Applying the inert substitution]
in TcFlatten
Note [EqualCtList invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* All are equalities
* All these equalities have the same LHS
* The list is never empty
* No element of the list can rewrite any other
* Derived before Wanted
From the fourth invariant it follows that the list is
 A single [G], or
 Zero or one [D] or [WD], followd by any number of [W]
The Wanteds can't rewrite anything which is why we put them last
Note [Type family equations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Typefamily equations, CFunEqCans, of form (ev : F tys ~ ty),
live in three places
* The worklist, of course
* The inert_funeqs are unsolved but fully processed, and in
the InertCans. They can be [G], [W], [WD], or [D].
* The inert_flat_cache. This is used when flattening, to get maximal
sharing. Everthing in the inert_flat_cache is [G] or [WD]
It contains lots of things that are still in the worklist.
E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work
list. Now if we flatten w2 before we get to w3, we still want to
share that (G a).
Because it contains worklist things, DO NOT use the flat cache to solve
a toplevel goal. Eg in the above example we don't want to solve w3
using w3 itself!
The CFunEqCan Ownership Invariant:
* Each [G/W/WD] CFunEqCan has a distinct fsk or fmv
It "owns" that fsk/fmv, in the sense that:
 reducing a [W/WD] CFunEqCan fills in the fmv
 unflattening a [W/WD] CFunEqCan fills in the fmv
(in both cases unless an occurscheck would result)
* In contrast a [D] CFunEqCan does not "own" its fmv:
 reducing a [D] CFunEqCan does not fill in the fmv;
it just generates an equality
 unflattening ignores [D] CFunEqCans altogether
Note [inert_eqs: the inert equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Definition [Canrewrite relation]
A "canrewrite" relation between flavours, written f1 >= f2, is a
binary relation with the following properties
(R1) >= is transitive
(R2) If f1 >= f, and f2 >= f,
then either f1 >= f2 or f2 >= f1
Lemma. If f1 >= f then f1 >= f1
Proof. By property (R2), with f1=f2
Definition [Generalised substitution]
A "generalised substitution" S is a set of triples (a f> t), where
a is a type variable
t is a type
f is a flavour
such that
(WF1) if (a f1> t1) in S
(a f2> t2) in S
then neither (f1 >= f2) nor (f2 >= f1) hold
(WF2) if (a f> t) is in S, then t /= a
Definition [Applying a generalised substitution]
If S is a generalised substitution
S(f,a) = t, if (a fs> t) in S, and fs >= f
= a, otherwise
Application extends naturally to types S(f,t), modulo roles.
See Note [Flavours with roles].
Theorem: S(f,a) is well defined as a function.
Proof: Suppose (a f1> t1) and (a f2> t2) are both in S,
and f1 >= f and f2 >= f
Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)
Notation: repeated application.
S^0(f,t) = t
S^(n+1)(f,t) = S(f, S^n(t))
Definition: inert generalised substitution
A generalised substitution S is "inert" iff
(IG1) there is an n such that
for every f,t, S^n(f,t) = S^(n+1)(f,t)
By (IG1) we define S*(f,t) to be the result of exahaustively
applying S(f,_) to t.

Our main invariant:
the inert CTyEqCans should be an inert generalised substitution

Note that inertness is not the same as idempotence. To apply S to a
type, you may have to apply it recursive. But inertness does
guarantee that this recursive use will terminate.
Note [Extending the inert equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Main Theorem [Stability under extension]
Suppose we have a "work item"
a fw> t
and an inert generalised substitution S,
THEN the extended substitution T = S+(a fw> t)
is an inert generalised substitution
PROVIDED
(T1) S(fw,a) = a  LHS of workitem is a fixpoint of S(fw,_)
(T2) S(fw,t) = t  RHS of workitem is a fixpoint of S(fw,_)
(T3) a not in t  No occurs check in the work item
AND, for every (b fs> s) in S:
(K0) not (fw >= fs)
Reason: suppose we kick out (a fs> s),
and add (a fw> t) to the inert set.
The latter can't rewrite the former,
so the kickout achieved nothing
OR { (K1) not (a = b)
Reason: if fw >= fs, WF1 says we can't have both
a fw> t and a fs> s
AND (K2): guarantees inertness of the new substitution
{ (K2a) not (fs >= fs)
OR (K2b) fs >= fw
OR (K2d) a not in s }
AND (K3) See Note [K3: completeness of solving]
{ (K3a) If the role of fs is nominal: s /= a
(K3b) If the role of fs is representational:
s is not of form (a t1 .. tn) } }
Conditions (T1T3) are established by the canonicaliser
Conditions (K1K3) are established by TcSMonad.kickOutRewritable
The idea is that
* (T12) are guaranteed by exhaustively rewriting the workitem
with S(fw,_).
* T3 is guaranteed by a simple occurscheck on the work item.
This is done during canonicalisation, in canEqTyVar;
(invariant: a CTyEqCan never has an occurs check).
* (K13) are the "kickout" criteria. (As stated, they are really the
"keep" criteria.) If the current inert S contains a triple that does
not satisfy (K13), then we remove it from S by "kicking it out",
and reprocessing it.
* Note that kicking out is a Bad Thing, because it means we have to
reprocess a constraint. The less we kick out, the better.
TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed
this but haven't done the empirical study to check.
* Assume we have G>=G, G>=W and that's all. Then, when performing
a unification we add a new given a G> ty. But doing so does NOT require
us to kick out an inert wanted that mentions a, because of (K2a). This
is a common case, hence good not to kick out.
* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing
Proof: using Definition [Canrewrite relation], fw can't rewrite anything
and so K0 holds. Intuitively, since fw can't rewrite anything,
adding it cannot cause any loops
This is a common case, because Wanteds cannot rewrite Wanteds.
It's used to avoid even looking for constraint to kick out.
* Lemma (L1): The conditions of the Main Theorem imply that there is no
(a fs> t) in S, s.t. (fs >= fw).
Proof. Suppose the contrary (fs >= fw). Then because of (T1),
S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we
have (a fs> a) in S, which contradicts (WF2).
* The extended substitution satisfies (WF1) and (WF2)
 (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).
 (T3) guarantees (WF2).
* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t),
T^1(f,t), T^2(f,T).... must pass through the new work item infinitely
often, since the substitution without the work item is inert; and must
pass through at least one of the triples in S infinitely often.
 (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),
and hence this triple never plays a role in application S(f,a).
It is always safe to extend S with such a triple.
(NB: we could strengten K1) in this way too, but see K3.
 (K2b): If this holds then, by (T2), b is not in t. So applying the
work item does not generate any new opportunities for applying S
 (K2c): If this holds, we can't pass through this triple infinitely
often, because if we did then fs>=f, fw>=f, hence by (R2)
* either fw>=fs, contradicting K2c
* or fs>=fw; so by the argument in K2b we can't have a loop
 (K2d): if a not in s, we hae no further opportunity to apply the
work item, similar to (K2b)
NB: Dimitrios has a PDF that does this in more detail
Key lemma to make it watertight.
Under the conditions of the Main Theorem,
forall f st fw >= f, a is not in S^k(f,t), for any k
Also, consider roles more carefully. See Note [Flavours with roles]
Note [K3: completeness of solving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(K3) is not necessary for the extended substitution
to be inert. In fact K1 could be made stronger by saying
... then (not (fw >= fs) or not (fs >= fs))
But it's not enough for S to be inert; we also want completeness.
That is, we want to be able to solve all soluble wanted equalities.
Suppose we have
workitem b G> a
inertitem a W> b
Assuming (G >= W) but not (W >= W), this fulfills all the conditions,
so we could extend the inerts, thus:
inertitems b G> a
a W> b
But if we kickedout the inert item, we'd get
workitem a W> b
inertitem b G> a
Then rewrite the workitem gives us (a W> a), which is soluble via Refl.
So we add one more clause to the kickout criteria
Another way to understand (K3) is that we treat an inert item
a f> b
in the same way as
b f> a
So if we kick out one, we should kick out the other. The orientation
is somewhat accidental.
When considering roles, we also need the second clause (K3b). Consider
workitem c G/N> a
inertitem a W/R> b c
The workitem doesn't get rewritten by the inert, because (>=) doesn't hold.
But we don't kick out the inert item because not (W/R >= W/R). So we just
add the work item. But then, consider if we hit the following:
workitem b G/N> Id
inertitems a W/R> b c
c G/N> a
where
newtype Id x = Id x
For similar reasons, if we only had (K3a), we wouldn't kick the
representational inert out. And then, we'd miss solving the inert, which
now reduced to reflexivity.
The solution here is to kick out representational inerts whenever the
tyvar of a work item is "exposed", where exposed means being at the
head of the toplevel application chain (a t1 .. tn). See
TcType.isTyVarHead. This is encoded in (K3b).
Beware: if we make this test succeed too often, we kick out too much,
and the solver might loop. Consider (Trac #14363)
work item: [G] a ~R f b
inert item: [G] b ~R f a
In GHC 8.2 the completeness tests more aggressive, and kicked out
the inert item; but no rewriting happened and there was an infinite
loop. All we need is to have the tyvar at the head.
Note [Flavours with roles]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The system described in Note [inert_eqs: the inert equalities]
discusses an abstract
set of flavours. In GHC, flavours have two components: the flavour proper,
taken from {Wanted, Derived, Given} and the equality relation (often called
role), taken from {NomEq, ReprEq}.
When substituting w.r.t. the inert set,
as described in Note [inert_eqs: the inert equalities],
we must be careful to respect all components of a flavour.
For example, if we have
inert set: a G/R> Int
b G/R> Bool
type role T nominal representational
and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT
T Int Bool. The reason is that T's first parameter has a nominal role, and
thus rewriting a to Int in T a b is wrong. Indeed, this noncongruence of
substitution means that the proof in Note [The inert equalities] may need
to be revisited, but we don't think that the end conclusion is wrong.
}
instance Outputable InertCans where
ppr (IC { inert_eqs = eqs
, inert_funeqs = funeqs, inert_dicts = dicts
, inert_safehask = safehask, inert_irreds = irreds
, inert_count = count })
= braces $ vcat
[ ppUnless (isEmptyDVarEnv eqs) $
text "Equalities:"
<+> pprCts (foldDVarEnv (\eqs rest > listToBag eqs `andCts` rest) emptyCts eqs)
, ppUnless (isEmptyTcAppMap funeqs) $
text "Typefunction equalities =" <+> pprCts (funEqsToBag funeqs)
, ppUnless (isEmptyTcAppMap dicts) $
text "Dictionaries =" <+> pprCts (dictsToBag dicts)
, ppUnless (isEmptyTcAppMap safehask) $
text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)
, ppUnless (isEmptyCts irreds) $
text "Irreds =" <+> pprCts irreds
, text "Unsolved goals =" <+> int count
]
{ *********************************************************************
* *
Shadow constraints and improvement
* *
************************************************************************
Note [The improvement story and derived shadows]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not
rewrite Wanteds] in TcRnTypes), we may miss some opportunities for
solving. Here's a classic example (indexedtypes/should_fail/T4093a)
Ambiguity check for f: (Foo e ~ Maybe e) => Foo e
We get [G] Foo e ~ Maybe e
[W] Foo e ~ Foo ee  ee is a unification variable
[W] Foo ee ~ Maybe ee
Flatten: [G] Foo e ~ fsk
[G] fsk ~ Maybe e  (A)
[W] Foo ee ~ fmv
[W] fmv ~ fsk  (B) From Foo e ~ Foo ee
[W] fmv ~ Maybe ee
> rewrite (B) with (A)
[W] Foo ee ~ fmv
[W] fmv ~ Maybe e
[W] fmv ~ Maybe ee
But now we appear to be stuck, since we don't rewrite Wanteds with
Wanteds. This is silly because we can see that ee := e is the
only solution.
The basic plan is
* generate Derived constraints that shadow Wanted constraints
* allow Derived to rewrite Derived
* in order to cause some unifications to take place
* that in turn solve the original Wanteds
The ONLY reason for all these Derived equalities is to tell us how to
unify a variable: that is, what Mark Jones calls "improvement".
The same idea is sometimes also called "saturation"; find all the
equalities that must hold in any solution.
Or, equivalently, you can think of the derived shadows as implementing
the "model": a nonidempotent but nooccurscheck substitution,
reflecting *all* *Nominal* equalities (a ~N ty) that are not
immediately soluble by unification.
More specifically, here's how it works (Oct 16):
* Wanted constraints are born as [WD]; this behaves like a
[W] and a [D] paired together.
* When we are about to add a [WD] to the inert set, if it can
be rewritten by a [D] a ~ ty, then we split it into [W] and [D],
putting the latter into the work list (see maybeEmitShadow).
In the example above, we get to the point where we are stuck:
[WD] Foo ee ~ fmv
[WD] fmv ~ Maybe e
[WD] fmv ~ Maybe ee
But now when [WD] fmv ~ Maybe ee is about to be added, we'll
split it into [W] and [D], since the inert [WD] fmv ~ Maybe e
can rewrite it. Then:
work item: [D] fmv ~ Maybe ee
inert: [W] fmv ~ Maybe ee
[WD] fmv ~ Maybe e  (C)
[WD] Foo ee ~ fmv
See Note [Splitting WD constraints]. Now the work item is rewritten
by (C) and we soon get ee := e.
Additional notes:
* The derived shadow equalities live in inert_eqs, along with
the Givens and Wanteds; see Note [EqualCtList invariants].
* We make Derived shadows only for Wanteds, not Givens. So we
have only [G], not [GD] and [G] plus splitting. See
Note [Add derived shadows only for Wanteds]
* We also get Derived equalities from functional dependencies
and typefunction injectivity; see calls to unifyDerived.
* This splitting business applies to CFunEqCans too; and then
we do apply typefunction reductions to the [D] CFunEqCan.
See Note [Reduction for Derived CFunEqCans]
* It's worth having [WD] rather than just [W] and [D] because
* efficiency: silly to process the same thing twice
* inert_funeqs, inert_dicts is a finite map keyed by
the type; it's inconvenient for it to map to TWO constraints
Note [Splitting WD constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are about to add a [WD] constraint to the inert set; and we
know that the inert set has fully rewritten it. Should we split
it into [W] and [D], and put the [D] in the work list for further
work?
* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):
Yes if the inert set could rewrite tys to make the class constraint,
or type family, fire. That is, yes if the inert_eqs intersects
with the free vars of tys. For this test we use
(anyRewritableTyVar True) which ignores casts and coercions in tys,
because rewriting the casts or coercions won't make the thing fire
more often.
* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.
We need to check both 'a' and 'ty' against the inert set:
 Inert set contains [D] a ~ ty2
Then we want to put [D] a ~ ty in the worklist, so we'll
get [D] ty ~ ty2 with consequent good things
 Inert set contains [D] b ~ a, where b is in ty.
We can't just add [WD] a ~ ty[b] to the inert set, because
that breaks the inertset invariants. If we tried to
canonicalise another [D] constraint mentioning 'a', we'd
get an infinite loop
Moreover we must use (anyRewritableTyVar False) for the RHS,
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 homokinded. 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:
f :: (UnF (F b) ~ b) => F b > ()
g :: forall a. (UnF (F a) ~ a) => a > ()
g _ = f (undefined :: F a)
For g we get [G] UnF (F a) ~ a
[WD] UnF (F beta) ~ beta
[WD] F a ~ F beta
Flatten:
[G] g1: F a ~ fsk1 fsk1 := F a
[G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1
[G] g3: fsk2 ~ a
[WD] w1: F beta ~ fmv1
[WD] w2: UnF fmv1 ~ fmv2
[WD] w3: fmv2 ~ beta
[WD] w4: fmv1 ~ fsk1  From F a ~ F beta using flatcache
 and reorient to put metavar on left
Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2
React that with g2: [D] d2: fmv2 ~ fsk2
React that with w3: [D] beta ~ fsk2
and g3: [D] beta ~ a  Hooray beta := a
And that is enough to solve everything
Note [Add derived shadows only for Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only add shadows for Wanted constraints. That is, we have
[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]
constraints.
It does just possibly make sense ot add a derived shadow for a
Given. If we created a Derived shadow of a Given, it could be
rewritten by other Deriveds, and that could, conceivably, lead to a
useful unification.
But (a) I have been unable to come up with an example of this
happening
(b) see Trac #12660 for how adding the derived shadows
of a Given led to an infinite loop.
(c) It's unlikely that rewriting derived Givens will lead
to a unification because Givens don't mention touchable
unification variables
For (b) there may be other ways to solve the loop, but simply
reraining from adding derived shadows of Givens is particularly
simple. And it's more efficient too!
Still, here's one possible reason for adding derived shadows
for Givens. Consider
workitem [G] a ~ [b], inerts has [D] b ~ a.
If we added the derived shadow (into the work list)
[D] a ~ [b]
When we process it, we'll rewrite to a ~ [a] and get an
occurs check. Without it we'll miss the occurs check (reporting
inaccessible code); but that's probably OK.
Note [Keep CDictCan shadows as CDictCan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
class C a => D a b
and [G] D a b, [G] C a in the inert set. Now we insert
[D] b ~ c. We want to kick out a derived shadow for [D] D a b,
so we can rewrite it with the new constraint, and perhaps get
instance reduction or other consequences.
BUT we do not want to kick out a *noncanonical* (D a b). If we
did, we would do this:
 rewrite it to [D] D a c, with pend_sc = True
 use expandSuperClasses to add C a
 go round again, which solves C a from the givens
This loop goes on for ever and triggers the simpl_loop limit.
Solution: kick out the CDictCan which will have pend_sc = False,
because we've already added its superclasses. So we won't readd
them. If we forget the pend_sc flag, our cunning scheme for avoiding
generating superclasses repeatedly will fail.
See Trac #11379 for a case of this.
Note [Do not do improvement for WOnly]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do improvement between two constraints (e.g. for injectivity
or functional dependencies) only if both are "improvable". And
we improve a constraint wrt the toplevel instances only if
it is improvable.
Improvable: [G] [WD] [D}
Not improvable: [W]
Reasons:
* It's less work: fewer pairs to compare
* Every [W] has a shadow [D] so nothing is lost
* Consider [WD] C Int b, where 'b' is a skolem, and
class C a b  a > b
instance C Int Bool
We'll do a fundep on it and emit [D] b ~ Bool
That will kick out constraint [WD] C Int b
Then we'll split it to [W] C Int b (keep in inert)
and [D] C Int b (in work list)
When processing the latter we'll rewrite it to
[D] C Int Bool
At that point it would be /stupid/ to interact it
with the inert [W] C Int b in the inert set; after all,
it's the very constraint from which the [D] C Int Bool
was split! We can avoid this by not doing improvement
on [W] constraints. This came up in Trac #12860.
}
maybeEmitShadow :: InertCans > Ct > TcS Ct
 See Note [The improvement story and derived shadows]
maybeEmitShadow ics ct
 let ev = ctEvidence ct
, CtWanted { ctev_pred = pred, ctev_loc = loc
, ctev_nosh = WDeriv } < ev
, shouldSplitWD (inert_eqs ics) ct
= do { traceTcS "Emit derived shadow" (ppr ct)
; let derived_ev = CtDerived { ctev_pred = pred
, ctev_loc = loc }
shadow_ct = ct { cc_ev = derived_ev }
 Te shadow constraint keeps the canonical shape.
 This just saves work, but is sometimes important;
 see Note [Keep CDictCan shadows as CDictCan]
; emitWork [shadow_ct]
; let ev' = ev { ctev_nosh = WOnly }
ct' = ct { cc_ev = ev' }
 Record that it now has a shadow
 This is /the/ place we set the flag to WOnly
; return ct' }
 otherwise
= return ct
shouldSplitWD :: InertEqs > Ct > Bool
 Precondition: 'ct' is [WD], and is inert
 True <=> we should split ct ito [W] and [D] because
 the inert_eqs can make progress on the [D]
 See Note [Splitting WD constraints]
shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })
= should_split_match_args inert_eqs tys
 We don't need to split if the tv is the RHS fsk
shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
= should_split_match_args inert_eqs tys
 NB True: ignore coercions
 See Note [Splitting WD constraints]
shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
, cc_eq_rel = eq_rel })
= tv `elemDVarEnv` inert_eqs
 anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
 NB False: do not ignore casts and coercions
 See Note [Splitting WD constraints]
shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
= anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
shouldSplitWD _ _ = False  No point in splitting otherwise
should_split_match_args :: InertEqs > [TcType] > Bool
 True if the inert_eqs can rewrite anything in the argument
 types, ignoring casts and coercions
should_split_match_args inert_eqs tys
= any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
 NB True: ignore casts coercions
 See Note [Splitting WD constraints]
canRewriteTv :: InertEqs > EqRel > TyVar > Bool
canRewriteTv inert_eqs eq_rel tv
 Just (ct : _) < lookupDVarEnv inert_eqs tv
, CTyEqCan { cc_eq_rel = eq_rel1 } < ct
= eq_rel1 `eqCanRewrite` eq_rel
 otherwise
= False
isImprovable :: CtEvidence > Bool
 See Note [Do not do improvement for WOnly]
isImprovable (CtWanted { ctev_nosh = WOnly }) = False
isImprovable _ = True
{ *********************************************************************
* *
Inert equalities
* *
********************************************************************* }
addTyEq :: InertEqs > TcTyVar > Ct > InertEqs
addTyEq old_eqs tv ct
= extendDVarEnv_C add_eq old_eqs tv [ct]
where
add_eq old_eqs _
 isWantedCt ct
, (eq1 : eqs) < old_eqs
= eq1 : ct : eqs
 otherwise
= ct : old_eqs
foldTyEqs :: (Ct > b > b) > InertEqs > b > b
foldTyEqs k eqs z
= foldDVarEnv (\cts z > foldr k z cts) z eqs
findTyEqs :: InertCans > TyVar > EqualCtList
findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []
delTyEq :: InertEqs > TcTyVar > TcType > InertEqs
delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv
where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
isThisOne _ = False
lookupInertTyVar :: InertEqs > TcTyVar > Maybe TcType
lookupInertTyVar ieqs tv
= case lookupDVarEnv ieqs tv of
Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) > Just rhs
_ > Nothing
lookupFlattenTyVar :: InertEqs > TcTyVar > TcType
 See Note [lookupFlattenTyVar]
lookupFlattenTyVar ieqs ftv
= lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv
{ Note [lookupFlattenTyVar]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have an injective function F and
inert_funeqs: F t1 ~ fsk1
F t2 ~ fsk2
inert_eqs: fsk1 ~ fsk2
We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to
get the [D] t1 ~ t2 from the injectiveness of F. So we look up the
cc_fsk of CFunEqCans in the inert_eqs when trying to find derived
equalities arising from injectivity.
}
{ *********************************************************************
* *
Adding an inert
* *
************************************************************************
Note [Adding an equality to the InertCans]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When adding an equality to the inerts:
* Split [WD] into [W] and [D] if the inerts can rewrite the latter;
done by maybeEmitShadow.
* Kick out any constraints that can be rewritten by the thing
we are adding. Done by kickOutRewritable.
* Note that unifying a:=ty, is like adding [G] a~ty; just use
kickOutRewritable with Nominal, Given. See kickOutAfterUnification.
Note [Kicking out CFunEqCan for fundeps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider:
New: [D] fmv1 ~ fmv2
Inert: [W] F alpha ~ fmv1
[W] F beta ~ fmv2
where F is injective. The new (derived) equality certainly can't
rewrite the inerts. But we *must* kick out the first one, to get:
New: [W] F alpha ~ fmv1
Inert: [W] F beta ~ fmv2
[D] fmv1 ~ fmv2
and now improvement will discover [D] alpha ~ beta. This is important;
eg in Trac #9587.
So in kickOutRewritable we look at all the tyvars of the
CFunEqCan, including the fsk.
}
addInertEq :: Ct > TcS ()
 This is a key function, because of the kickout stuff
 Precondition: item /is/ canonical
 See Note [Adding an equality to the InertCans]
addInertEq ct
= do { traceTcS "addInertEq {" $
text "Adding new inert equality:" <+> ppr ct
; ics < getInertCans
; ct@(CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel })
< maybeEmitShadow ics ct
; (_, ics1) < kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
; let ics2 = ics1 { inert_eqs = addTyEq (inert_eqs ics1) tv ct
, inert_count = bumpUnsolvedCount ev (inert_count ics1) }
; setInertCans ics2
; traceTcS "addInertEq }" $ empty }

addInertCan :: Ct > TcS ()  Constraints *other than* equalities
addInertCan ct
= do { traceTcS "insertInertCan {" $
text "Trying to insert new noneq inert item:" <+> ppr ct
; ics < getInertCans
; ct < maybeEmitShadow ics ct
; setInertCans (add_item ics ct)
; traceTcS "addInertCan }" $ empty }
add_item :: InertCans > Ct > InertCans
add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
= ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
add_item ics@(IC { inert_irreds = irreds, inert_count = count })
item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })
= ics { inert_irreds = irreds `Bag.snocBag` item
, inert_count = if insoluble
then count  inert_count does not include insolubles
else bumpUnsolvedCount ev count }
add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
= ics { inert_dicts = addDict (inert_dicts ics) cls tys item
, inert_count = bumpUnsolvedCount ev (inert_count ics) }
add_item _ item
= pprPanic "upd_inert set: can't happen! Inserting " $
ppr item  CTyEqCan is dealt with by addInertEq
 Can't be CNonCanonical, CHoleCan,
 because they only land in inert_irreds
bumpUnsolvedCount :: CtEvidence > Int > Int
bumpUnsolvedCount ev n  isWanted ev = n+1
 otherwise = n

kickOutRewritable :: CtFlavourRole  Flavour/role of the equality that
 is being added to the inert set
> TcTyVar  The new equality is tv ~ ty
> InertCans
> TcS (Int, InertCans)
kickOutRewritable new_fr new_tv ics
= do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics
n_kicked = workListSize kicked_out
; unless (n_kicked == 0) $
do { updWorkListTcS (appendWorkList kicked_out)
; csTraceTcS $
hang (text "Kick out, tv =" <+> ppr new_tv)
2 (vcat [ text "nkicked =" <+> int n_kicked
, text "kicked_out =" <+> ppr kicked_out
, text "Residual inerts =" <+> ppr ics' ]) }
; return (n_kicked, ics') }
kick_out_rewritable :: CtFlavourRole  Flavour/role of the equality that
 is being added to the inert set
> TcTyVar  The new equality is tv ~ ty
> InertCans
> (WorkList, InertCans)
 See Note [kickOutRewritable]
kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs = tv_eqs
, inert_dicts = dictmap
, inert_safehask = safehask
, inert_funeqs = funeqmap
, inert_irreds = irreds
, inert_count = n })
 not (new_fr `eqMayRewriteFR` new_fr)
= (emptyWorkList, ics)
 If new_fr can't rewrite itself, it can't rewrite
 anything else, so no need to kick out anything.
 (This is a common case: wanteds can't rewrite wanteds)
 Lemma (L2) in Note [Extending the inert equalities]
 otherwise
= (kicked_out, inert_cans_in)
where
inert_cans_in = IC { inert_eqs = tv_eqs_in
, inert_dicts = dicts_in
, inert_safehask = safehask  ??
, inert_funeqs = feqs_in
, inert_irreds = irs_in
, inert_count = n  workListWantedCount kicked_out }
kicked_out :: WorkList
 NB: use extendWorkList to ensure that kickedout equalities get priority
 See Note [Prioritise equality constraints] (Kickout).
 The irreds may include noncanonical (heterokinded) equality
 constraints, which perhaps may have become soluble after new_tv
 is substituted; ditto the dictionaries, which may include (a~b)
 or (a~~b) constraints.
kicked_out = foldrBag extendWorkListCt
(emptyWorkList { wl_eqs = tv_eqs_out
, wl_funeqs = feqs_out })
(dicts_out `andCts` irs_out)
(tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
(feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap
 See Note [Kicking out CFunEqCan for fundeps]
(dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap
(irs_out, irs_in) = partitionBag kick_out_ct irreds
 Kick out even insolubles: See Note [Rewrite insolubles]
 Of course we must kick out irreducibles like (c a), in case
 we can rewrite 'c' to something more useful
(_, new_role) = new_fr
fr_can_rewrite_ty :: EqRel > Type > Bool
fr_can_rewrite_ty role ty = anyRewritableTyVar False role
fr_can_rewrite_tv ty
fr_can_rewrite_tv :: EqRel > TyVar > Bool
fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
&& tv == new_tv
fr_may_rewrite :: CtFlavourRole > Bool
fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
 Can the new item rewrite the inert item?
kick_out_ct :: Ct > Bool
 Kick it out if the new CTyEqCan can rewrite the inert one
 See Note [kickOutRewritable]
kick_out_ct ct  let fs@(_,role) = ctFlavourRole ct
= fr_may_rewrite fs
&& fr_can_rewrite_ty role (ctPred ct)
 False: ignore casts and coercions
 NB: this includes the fsk of a CFunEqCan. It can't
 actually be rewritten, but we need to kick it out
 so we get to take advantage of injectivity
 See Note [Kicking out CFunEqCan for fundeps]
kick_out_eqs :: EqualCtList > ([Ct], DTyVarEnv EqualCtList)
> ([Ct], DTyVarEnv EqualCtList)
kick_out_eqs eqs (acc_out, acc_in)
= (eqs_out ++ acc_out, case eqs_in of
[] > acc_in
(eq1:_) > extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
where
(eqs_out, eqs_in) = partition kick_out_eq eqs
 Implements criteria K1K3 in Note [Extending the inert equalities]
kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
, cc_ev = ev, cc_eq_rel = eq_rel })
 not (fr_may_rewrite fs)
= False  Keep it in the inert set if the new thing can't rewrite it
 Below here (fr_may_rewrite fs) is True
 tv == new_tv = True  (K1)
 kick_out_for_inertness = True
 kick_out_for_completeness = True
 otherwise = False
where
fs = (ctEvFlavour ev, eq_rel)
kick_out_for_inertness
= (fs `eqMayRewriteFR` fs)  (K2a)
&& not (fs `eqMayRewriteFR` new_fr)  (K2b)
&& fr_can_rewrite_ty eq_rel rhs_ty  (K2d)
 (K2c) is guaranteed by the first guard of keep_eq
kick_out_for_completeness
= case eq_rel of
NomEq > rhs_ty `eqType` mkTyVarTy new_tv
ReprEq > isTyVarHead new_tv rhs_ty
kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
kickOutAfterUnification :: TcTyVar > TcS Int
kickOutAfterUnification new_tv
= do { ics < getInertCans
; (n_kicked, ics2) < kickOutRewritable (Given,NomEq)
new_tv ics
 Given because the tv := xi is given; NomEq because
 only nominal equalities are solved by unification
; setInertCans ics2
; return n_kicked }
{ Note [kickOutRewritable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [inert_eqs: the inert equalities].
When we add a new inert equality (a ~N ty) to the inert set,
we must kick out any inert items that could be rewritten by the
new equality, to maintain the inertset invariants.
 We want to kick out an existing inert constraint if
a) the new constraint can rewrite the inert one
b) 'a' is free in the inert constraint (so that it *will*)
rewrite it if we kick it out.
For (b) we use tyCoVarsOfCt, which returns the type variables /and
the kind variables/ that are directly visible in the type. Hence
we will have exposed all the rewriting we care about to make the
most precise kinds visible for matching classes etc. No need to
kick out constraints that mention type variables whose kinds
contain this variable!
 A Derived equality can kick out [D] constraints in inert_eqs,
inert_dicts, inert_irreds etc.
 We don't kick out constraints from inert_solved_dicts, and
inert_solved_funeqs optimistically. But when we lookup we have to
take the substitution into account
Note [Rewrite insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have an insoluble alpha ~ [alpha], which is insoluble
because an occurs check. And then we unify alpha := [Int]. Then we
really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can
be decomposed. Otherwise we end up with a "Can't match [Int] ~
[[Int]]" which is true, but a bit confusing because the outer type
constructors match.
Similarly, if we have a CHoleCan, we'd like to rewrite it with any
Givens, to give as informative an error messasge as possible
(Trac #12468, #11325).
Hence:
* In the main simlifier loops in TcSimplify (solveWanteds,
simpl_loop), we feed the insolubles in solveSimpleWanteds,
so that they get rewritten (albeit not solved).
* We kick insolubles out of the inert set, if they can be
rewritten (see TcSMonad.kick_out_rewritable)
* We rewrite those insolubles in TcCanonical.
See Note [Make sure that insolubles are fully rewritten]
}

addInertSafehask :: InertCans > Ct > InertCans
addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
= ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
addInertSafehask _ item
= pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
insertSafeOverlapFailureTcS :: Ct > TcS ()
 See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
insertSafeOverlapFailureTcS item
= updInertCans (\ics > addInertSafehask ics item)
getSafeOverlapFailures :: TcS Cts
 See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
getSafeOverlapFailures
= do { IC { inert_safehask = safehask } < getInertCans
; return $ foldDicts consCts safehask emptyCts }

addSolvedDict :: CtEvidence > Class > [Type] > TcS ()
 Add a new item in the solved set of the monad
 See Note [Solved dictionaries]
addSolvedDict item cls tys
 isIPPred (ctEvPred item)  Never cache "solved" implicit parameters (not sure why!)
= return ()
 otherwise
= do { traceTcS "updSolvedSetTcs:" $ ppr item
; updInertTcS $ \ ics >
ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
getSolvedDicts :: TcS (DictMap CtEvidence)
getSolvedDicts = do { ics < getTcSInerts; return (inert_solved_dicts ics) }
setSolvedDicts :: DictMap CtEvidence > TcS ()
setSolvedDicts solved_dicts
= updInertTcS $ \ ics >
ics { inert_solved_dicts = solved_dicts }
{ *********************************************************************
* *
Other inertset operations
* *
********************************************************************* }
updInertTcS :: (InertSet > InertSet) > TcS ()
 Modify the inert set with the supplied function
updInertTcS upd_fn
= do { is_var < getTcSInertsRef
; wrapTcS (do { curr_inert < TcM.readTcRef is_var
; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
getInertCans :: TcS InertCans
getInertCans = do { inerts < getTcSInerts; return (inert_cans inerts) }
setInertCans :: InertCans > TcS ()
setInertCans ics = updInertTcS $ \ inerts > inerts { inert_cans = ics }
updRetInertCans :: (InertCans > (a, InertCans)) > TcS a
 Modify the inert set with the supplied function
updRetInertCans upd_fn
= do { is_var < getTcSInertsRef
; wrapTcS (do { inerts < TcM.readTcRef is_var
; let (res, cans') = upd_fn (inert_cans inerts)
; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
; return res }) }
updInertCans :: (InertCans > InertCans) > TcS ()
 Modify the inert set with the supplied function
updInertCans upd_fn
= updInertTcS $ \ inerts > inerts { inert_cans = upd_fn (inert_cans inerts) }
updInertDicts :: (DictMap Ct > DictMap Ct) > TcS ()
 Modify the inert set with the supplied function
updInertDicts upd_fn
= updInertCans $ \ ics > ics { inert_dicts = upd_fn (inert_dicts ics) }
updInertSafehask :: (DictMap Ct > DictMap Ct) > TcS ()
 Modify the inert set with the supplied function
updInertSafehask upd_fn
= updInertCans $ \ ics > ics { inert_safehask = upd_fn (inert_safehask ics) }
updInertFunEqs :: (FunEqMap Ct > FunEqMap Ct) > TcS ()
 Modify the inert set with the supplied function
updInertFunEqs upd_fn
= updInertCans $ \ ics > ics { inert_funeqs = upd_fn (inert_funeqs ics) }
updInertIrreds :: (Cts > Cts) > TcS ()
 Modify the inert set with the supplied function
updInertIrreds upd_fn
= updInertCans $ \ ics > ics { inert_irreds = upd_fn (inert_irreds ics) }
getInertEqs :: TcS (DTyVarEnv EqualCtList)
getInertEqs = do { inert < getInertCans; return (inert_eqs inert) }
getInertInsols :: TcS Cts
 Returns insoluble equality constraints
 specifically including Givens
getInertInsols = do { inert < getInertCans
; return (filterBag insolubleEqCt (inert_irreds inert)) }
getInertGivens :: TcS [Ct]
 Returns the Given constraints in the inert set,
 with type functions *not* unflattened
getInertGivens
= do { inerts < getInertCans
; let all_cts = foldDicts (:) (inert_dicts inerts)
$ foldFunEqs (:) (inert_funeqs inerts)
$ concat (dVarEnvElts (inert_eqs inerts))
; return (filter isGivenCt all_cts) }
getPendingScDicts :: TcS [Ct]
 Find all inert Given dictionaries whose cc_pend_sc flag is True
 Set the flag to False in the inert set, and return that Ct
getPendingScDicts = updRetInertCans get_sc_dicts
where
get_sc_dicts ic@(IC { inert_dicts = dicts })
= (sc_pend_dicts, ic')
where
ic' = ic { inert_dicts = foldr add dicts sc_pend_dicts }
sc_pend_dicts :: [Ct]
sc_pend_dicts = foldDicts get_pending dicts []
get_pending :: Ct > [Ct] > [Ct]  Get dicts with cc_pend_sc = True
 but flipping the flag
get_pending dict dicts
 Just dict' < isPendingScDict dict = dict' : dicts
 otherwise = dicts
add :: Ct > DictMap Ct > DictMap Ct
add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
= addDict dicts cls tys ct
add ct _ = pprPanic "getPendingScDicts" (ppr ct)
getUnsolvedInerts :: TcS ( Bag Implication
, Cts  Tyvar eqs: a ~ ty
, Cts  Fun eqs: F a ~ ty
, Cts )  All others
 Return all the unsolved [Wanted] or [Derived] constraints

 Postcondition: the returned simple constraints are all fully zonked
 (because they come from the inert set)
 the unsolved implics may not be
getUnsolvedInerts
= do { IC { inert_eqs = tv_eqs
, inert_funeqs = fun_eqs
, inert_irreds = irreds
, inert_dicts = idicts
} < getInertCans
; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts
unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts
unsolved_irreds = Bag.filterBag is_unsolved irreds
unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts
unsolved_others = unsolved_irreds `unionBags` unsolved_dicts
; implics < getWorkListImplics
; traceTcS "getUnsolvedInerts" $
vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
, text "fun eqs =" <+> ppr unsolved_fun_eqs
, text "others =" <+> ppr unsolved_others
, text "implics =" <+> ppr implics ]
; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
where
add_if_unsolved :: Ct > Cts > Cts
add_if_unsolved ct cts  is_unsolved ct = ct `consCts` cts
 otherwise = cts
is_unsolved ct = not (isGivenCt ct)  Wanted or Derived
 For CFunEqCans we ignore the Derived ones, and keep
 only the Wanteds for flattening. The Derived ones
 share a unification variable with the corresponding
 Wanted, so we definitely don't want to participate
 in unflattening
 See Note [Type family equations]
add_if_wanted ct cts  isWantedCt ct = ct `consCts` cts
 otherwise = cts
isInInertEqs :: DTyVarEnv EqualCtList > TcTyVar > TcType > Bool
 True if (a ~N ty) is in the inert set, in either Given or Wanted
isInInertEqs eqs tv rhs
= case lookupDVarEnv eqs tv of
Nothing > False
Just cts > any (same_pred rhs) cts
where
same_pred rhs ct
 CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } < ct
, NomEq < eq_rel
, rhs `eqType` rhs2 = True
 otherwise = False
getNoGivenEqs :: TcLevel  TcLevel of this implication
> [TcTyVar]  Skolems of this implication
> TcS ( Bool  True <=> definitely no residual given equalities
, Cts )  Insoluble equalities arising from givens
 See Note [When does an implication have given equalities?]
getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
< getInertCans
; let has_given_eqs = foldrBag (() . ct_given_here) False irreds
 anyDVarEnv eqs_given_here ieqs
insols = filterBag insolubleEqCt irreds
 Specifically includes ones that originated in some
 outer context but were refined to an insoluble by
 a local equality; so do /not/ add ct_given_here.
; traceTcS "getNoGivenEqs" $
vcat [ if has_given_eqs then text "May have given equalities"
else text "No given equalities"
, text "Skols:" <+> ppr skol_tvs
, text "Inerts:" <+> ppr inerts
, text "Insols:" <+> ppr insols]
; return (not has_given_eqs, insols) }
where
eqs_given_here :: EqualCtList > Bool
eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
 Givens are always a sigleton
= not (skolem_bound_here tv) && ct_given_here ct
eqs_given_here _ = False
ct_given_here :: Ct > Bool
 True for a Given bound by the current implication,
 i.e. the current level
ct_given_here ct = isGiven ev
&& tclvl == ctLocLevel (ctEvLoc ev)
where
ev = ctEvidence ct
skol_tv_set = mkVarSet skol_tvs
skolem_bound_here tv  See Note [Letbound skolems]
= case tcTyVarDetails tv of
SkolemTv {} > tv `elemVarSet` skol_tv_set
_ > False
  Returns Given constraints that might,
 potentially, match the given pred. This is used when checking to see if a
 Given might overlap with an instance. See Note [Instance and Given overlap]
 in TcInteract.
matchableGivens :: CtLoc > PredType > InertSet > Cts
matchableGivens loc_w pred (IS { inert_cans = inert_cans })
= filterBag matchable_given all_relevant_givens
where
 just look in class constraints and irreds. matchableGivens does get called
 for ~R constraints, but we don't need to look through equalities, because
 canonical equalities are used for rewriting. We'll only get caught by
 noncanonical  that is, irreducible  equalities.
all_relevant_givens :: Cts
all_relevant_givens
 Just (clas, _) < getClassPredTys_maybe pred
= findDictsByClass (inert_dicts inert_cans) clas
`unionBags` inert_irreds inert_cans
 otherwise
= inert_irreds inert_cans
matchable_given :: Ct > Bool
matchable_given ct
 CtGiven { ctev_loc = loc_g } < ctev
, Just _ < tcUnifyTys bind_meta_tv [ctEvPred ctev] [pred]
, not (prohibitedSuperClassSolve loc_g loc_w)
= True
 otherwise
= False
where
ctev = cc_ev ct
bind_meta_tv :: TcTyVar > BindFlag
 Any meta tyvar may be unified later, so we treat it as
 bindable when unifying with givens. That ensures that we
 conservatively assume that a meta tyvar might get unified with
 something that matches the 'given', until demonstrated
 otherwise. More info in Note [Instance and Given overlap]
 in TcInteract
bind_meta_tv tv  isMetaTyVar tv
, not (isFskTyVar tv) = BindMe
 otherwise = Skolem
prohibitedSuperClassSolve :: CtLoc > CtLoc > Bool
 See Note [Solving superclass constraints] in TcInstDcls
prohibitedSuperClassSolve from_loc solve_loc
 GivenOrigin (InstSC given_size) < ctLocOrigin from_loc
, ScOrigin wanted_size < ctLocOrigin solve_loc
= given_size >= wanted_size
 otherwise
= False
{ Note [Unsolved Derived equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In getUnsolvedInerts, we return a derived equality from the inert_eqs
because it is a candidate for floating out of this implication. We
only float equalities with a metatyvar on the left, so we only pull
those out here.
Note [When does an implication have given equalities?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider an implication
beta => alpha ~ Int
where beta is a unification variable that has already been unified
to () in an outer scope. Then we can float the (alpha ~ Int) out
just fine. So when deciding whether the givens contain an equality,
we should canonicalise first, rather than just looking at the original
givens (Trac #8644).
So we simply look at the inert, canonical Givens and see if there are
any equalities among them, the calculation of has_given_eqs. There
are some wrinkles:
* We must know which ones are bound in *this* implication and which
are bound further out. We can find that out from the TcLevel
of the Given, which is itself recorded in the tcl_tclvl field
of the TcLclEnv stored in the Given (ev_given_here).
What about interactions between inner and outer givens?
 Outer given is rewritten by an inner given, then there must
have been an inner given equality, hence the “giveneq” flag
will be true anyway.
 Inner given rewritten by outer, retains its level (ie. The inner one)
* We must take account of *potential* equalities, like the one above:
beta => ...blah...
If we still don't know what beta is, we conservatively treat it as potentially
becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.
* When flattening givens, we generate Given equalities like
: F [a] ~ f,
with Refl evidence, and we *don't* want those to count as an equality
in the givens! After all, the entire flattening business is just an
internal matter, and the evidence does not mention any of the 'givens'
of this implication. So we do not treat inert_funeqs as a 'given equality'.
* See Note [Letbound skolems] for another wrinkle
* We do *not* need to worry about representational equalities, because
these do not affect the ability to float constraints.
Note [Letbound skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
If * the inert set contains a canonical Given CTyEqCan (a ~ ty)
and * 'a' is a skolem bound in this very implication, b
then:
a) The Given is pretty much a letbinding, like
f :: (a ~ b>c) => a > a
Here the equality constraint is like saying
let a = b>c in ...
It is not adding any new, local equality information,
and hence can be ignored by has_given_eqs
b) 'a' will have been completely substituted out in the inert set,
so we can safely discard it. Notably, it doesn't need to be
returned as part of 'fsks'
For an example, see Trac #9211.
See also TcUnify Note [Deeper level on the left] for how we ensure
that the right variable is on the left of the equality when both are
tyvars.
}
removeInertCts :: [Ct] > InertCans > InertCans
 ^ Remove inert constraints from the 'InertCans', for use when a
 typechecker plugin wishes to discard a given.
removeInertCts cts icans = foldl' removeInertCt icans cts
removeInertCt :: InertCans > Ct > InertCans
removeInertCt is ct =
case ct of
CDictCan { cc_class = cl, cc_tyargs = tys } >
is { inert_dicts = delDict (inert_dicts is) cl tys }
CFunEqCan { cc_fun = tf, cc_tyargs = tys } >
is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
CTyEqCan { cc_tyvar = x, cc_rhs = ty } >
is { inert_eqs = delTyEq (inert_eqs is) x ty }
CIrredCan {} > panic "removeInertCt: CIrredEvCan"
CNonCanonical {} > panic "removeInertCt: CNonCanonical"
CHoleCan {} > panic "removeInertCt: CHoleCan"
lookupFlatCache :: TyCon > [Type] > TcS (Maybe (TcCoercion, TcType, CtFlavour))
lookupFlatCache fam_tc tys
= do { IS { inert_flat_cache = flat_cache
, inert_cans = IC { inert_funeqs = inert_funeqs } } < getTcSInerts
; return (firstJusts [lookup_inerts inert_funeqs,
lookup_flats flat_cache]) }
where
lookup_inerts inert_funeqs
 Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })
< findFunEq inert_funeqs fam_tc tys
, tys `eqTypes` xis  The lookup might find a nearmatch; see
 Note [Use loose types in inert set]
= Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
 otherwise = Nothing
lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
lookupInInerts :: CtLoc > TcPredType > TcS (Maybe CtEvidence)
 Is this exact predicate type cached in the solved or canonicals of the InertSet?
lookupInInerts loc pty
 ClassPred cls tys < classifyPredType pty
= do { inerts < getTcSInerts
; return (lookupSolvedDict inerts loc cls tys `mplus`
lookupInertDict (inert_cans inerts) loc cls tys) }
 otherwise  NB: No caching for equalities, IPs, holes, or errors
= return Nothing
  Look up a dictionary inert. NB: the returned 'CtEvidence' might not
 match the input exactly. Note [Use loose types in inert set].
lookupInertDict :: InertCans > CtLoc > Class > [Type] > Maybe CtEvidence
lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
= case findDict dicts loc cls tys of
Just ct > Just (ctEvidence ct)
_ > Nothing
  Look up a solved inert. NB: the returned 'CtEvidence' might not
 match the input exactly. See Note [Use loose types in inert set].
lookupSolvedDict :: InertSet > CtLoc > Class > [Type] > Maybe CtEvidence
 Returns just if exactly this predicate type exists in the solved.
lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
= case findDict solved loc cls tys of
Just ev > Just ev
_ > Nothing
{ *********************************************************************
* *
Irreds
* *
********************************************************************* }
foldIrreds :: (Ct > b > b) > Cts > b > b
foldIrreds k irreds z = foldrBag k z irreds
{ *********************************************************************
* *
TcAppMap
* *
************************************************************************
Note [Use loose types in inert set]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Say we know (Eq (a > c1)) and we need (Eq (a > c2)). One is clearly
solvable from the other. So, we do lookup in the inert set using
loose types, which omit the kindcheck.
We must be careful when using the result of a lookup because it may
not match the requested info exactly!
}
type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)
 Indexed by tycon then the arg types, using "loose" matching, where
 we don't require kind equality. This allows, for example, (a > co)
 to match (a).
 See Note [Use loose types in inert set]
 Used for types and classes; hence UniqDFM
 See Note [foldTM determinism] for why we use UniqDFM here
isEmptyTcAppMap :: TcAppMap a > Bool
isEmptyTcAppMap m = isNullUDFM m
emptyTcAppMap :: TcAppMap a
emptyTcAppMap = emptyUDFM
findTcApp :: TcAppMap a > Unique > [Type] > Maybe a
findTcApp m u tys = do { tys_map < lookupUDFM m u
; lookupTM tys tys_map }
delTcApp :: TcAppMap a > Unique > [Type] > TcAppMap a
delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls
insertTcApp :: TcAppMap a > Unique > [Type] > a > TcAppMap a
insertTcApp m cls tys ct = alterUDFM alter_tm m cls
where
alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
 mapTcApp :: (a>b) > TcAppMap a > TcAppMap b
 mapTcApp f = mapUDFM (mapTM f)
filterTcAppMap :: (Ct > Bool) > TcAppMap Ct > TcAppMap Ct
filterTcAppMap f m
= mapUDFM do_tm m
where
do_tm tm = foldTM insert_mb tm emptyTM
insert_mb ct tm
 f ct = insertTM tys ct tm
 otherwise = tm
where
tys = case ct of
CFunEqCan { cc_tyargs = tys } > tys
CDictCan { cc_tyargs = tys } > tys
_ > pprPanic "filterTcAppMap" (ppr ct)
tcAppMapToBag :: TcAppMap a > Bag a
tcAppMapToBag m = foldTcAppMap consBag m emptyBag
foldTcAppMap :: (a > b > b) > TcAppMap a > b > b
foldTcAppMap k m z = foldUDFM (foldTM k) z m
{ *********************************************************************
* *
DictMap
* *
********************************************************************* }
{ Note [Tuples hiding implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f,g :: (?x::Int, C a) => a > a
f v = let ?x = 4 in g v
The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). Trac #14218.
We deal with this by arranging that we always fail when looking up a
tuple constraint that hides an implicit parameter. Not that this applies
* both to the inert_dicts (lookupInertDict)
* and to the solved_dicts (looukpSolvedDict)
An alternative would be not to extend these sets with such tuple
constraints, but it seemed more direct to deal with the lookup.
Note [Solving CallStack constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose f :: HasCallStack => blah. Then
* Each call to 'f' gives rise to
[W] s1 :: IP "callStack" CallStack  CtOrigin = OccurrenceOf f
with a CtOrigin that says "OccurrenceOf f".
Remember that HasCallStack is just shorthand for
IP "callStack CallStack
See Note [Overview of implicit CallStacks] in TcEvidence
* We cannonicalise such constraints, in TcCanonical.canClassNC, by
pushing the callsite info on the stack, and changing the CtOrigin
to record that has been done.
Bind: s1 = pushCallStack s2
[W] s2 :: IP "callStack" CallStack  CtOrigin = IPOccOrigin
* Then, and only then, we can solve the constraint from an enclosing
Given.
So we must be careful /not/ to solve 's1' from the Givens. Again,
we ensure this by arranging that findDict always misses when looking
up souch constraints.
}
type DictMap a = TcAppMap a
emptyDictMap :: DictMap a
emptyDictMap = emptyTcAppMap
findDict :: DictMap a > CtLoc > Class > [Type] > Maybe a
findDict m loc cls tys
 isCTupleClass cls
, any hasIPPred tys  See Note [Tuples hiding implicit parameters]
= Nothing
 Just {} < isCallStackPred cls tys
, OccurrenceOf {} < ctLocOrigin loc
= Nothing  See Note [Solving CallStack constraints]
 otherwise
= findTcApp m (getUnique cls) tys
findDictsByClass :: DictMap a > Class > Bag a
findDictsByClass m cls
 Just tm < lookupUDFM m cls = foldTM consBag tm emptyBag
 otherwise = emptyBag
delDict :: DictMap a > Class > [Type] > DictMap a
delDict m cls tys = delTcApp m (getUnique cls) tys
addDict :: DictMap a > Class > [Type] > a > DictMap a
addDict m cls tys item = insertTcApp m (getUnique cls) tys item
addDictsByClass :: DictMap Ct > Class > Bag Ct > DictMap Ct
addDictsByClass m cls items
= addToUDFM m cls (foldrBag add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
filterDicts :: (Ct > Bool) > DictMap Ct > DictMap Ct
filterDicts f m = filterTcAppMap f m
partitionDicts :: (Ct > Bool) > DictMap Ct > (Bag Ct, DictMap Ct)
partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)
where
k ct (yeses, noes)  f ct = (ct `consBag` yeses, noes)
 otherwise = (yeses, add ct noes)
add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m
= addDict m cls tys ct
add ct _ = pprPanic "partitionDicts" (ppr ct)
dictsToBag :: DictMap a > Bag a
dictsToBag = tcAppMapToBag
foldDicts :: (a > b > b) > DictMap a > b > b
foldDicts = foldTcAppMap
emptyDicts :: DictMap a
emptyDicts = emptyTcAppMap
{ *********************************************************************
* *
FunEqMap
* *
********************************************************************* }
type FunEqMap a = TcAppMap a  A map whose key is a (TyCon, [Type]) pair
emptyFunEqs :: TcAppMap a
emptyFunEqs = emptyTcAppMap
findFunEq :: FunEqMap a > TyCon > [Type] > Maybe a
findFunEq m tc tys = findTcApp m (getUnique tc) tys
funEqsToBag :: FunEqMap a > Bag a
funEqsToBag m = foldTcAppMap consBag m emptyBag
findFunEqsByTyCon :: FunEqMap a > TyCon > [a]
 Get inert function equation constraints that have the given tycon
 in their head. Not that the constraints remain in the inert set.
 We use this to check for derived interactions with builtin typefunction
 constructors.
findFunEqsByTyCon m tc
 Just tm < lookupUDFM m tc = foldTM (:) tm []
 otherwise = []
foldFunEqs :: (a > b > b) > FunEqMap a > b > b
foldFunEqs = foldTcAppMap
 mapFunEqs :: (a > b) > FunEqMap a > FunEqMap b
 mapFunEqs = mapTcApp
 filterFunEqs :: (Ct > Bool) > FunEqMap Ct > FunEqMap Ct
 filterFunEqs = filterTcAppMap
insertFunEq :: FunEqMap a > TyCon > [Type] > a > FunEqMap a
insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
partitionFunEqs :: (Ct > Bool) > FunEqMap Ct > ([Ct], FunEqMap Ct)
 Optimise for the case where the predicate is false
 partitionFunEqs is called only from kickout, and kickout usually
 kicks out very few equalities, so we want to optimise for that case
partitionFunEqs f m = (yeses, foldr del m yeses)
where
yeses = foldTcAppMap k m []
k ct yeses  f ct = ct : yeses
 otherwise = yeses
del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
= delFunEq m tc tys
del ct _ = pprPanic "partitionFunEqs" (ppr ct)
delFunEq :: FunEqMap a > TyCon > [Type] > FunEqMap a
delFunEq m tc tys = delTcApp m (getUnique tc) tys

type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = emptyUFM
findExactFunEq :: ExactFunEqMap a > TyCon > [Type] > Maybe a
findExactFunEq m tc tys = do { tys_map < lookupUFM m (getUnique tc)
; lookupTM tys tys_map }
insertExactFunEq :: ExactFunEqMap a > TyCon > [Type] > a > ExactFunEqMap a
insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)
where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
{
************************************************************************
* *
* The TcS solver monad *
* *
************************************************************************
Note [The TcS monad]
~~~~~~~~~~~~~~~~~~~~
The TcS monad is a weak form of the main Tc monad
All you can do is
* fail
* allocate new variables
* fill in evidence variables
Filling in a dictionary evidence variable means to create a binding
for it, so TcS carries a mutable location where the binding can be
added. This is initialised from the innermost implication constraint.
}
data TcSEnv
= TcSEnv {
tcs_ev_binds :: EvBindsVar,
tcs_unified :: IORef Int,
 The number of unification variables we have filled
 The important thing is whether it is nonzero
tcs_count :: IORef Int,  Global step count
tcs_inerts :: IORef InertSet,  Current inert set
 The main worklist and the flattening worklist
 See Note [Work list priorities] and
tcs_worklist :: IORef WorkList  Current worklist
}

newtype TcS a = TcS { unTcS :: TcSEnv > TcM a }
instance Functor TcS where
fmap f m = TcS $ fmap f . unTcS m
instance Applicative TcS where
pure x = TcS (\_ > return x)
(<*>) = ap
instance Monad TcS where
fail = MonadFail.fail
m >>= k = TcS (\ebs > unTcS m ebs >>= \r > unTcS (k r) ebs)
instance MonadFail.MonadFail TcS where
fail err = TcS (\_ > fail err)
instance MonadUnique TcS where
getUniqueSupplyM = wrapTcS getUniqueSupplyM
instance HasModule TcS where
getModule = wrapTcS getModule
instance MonadThings TcS where
lookupThing n = wrapTcS (lookupThing n)
 Basic functionality
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
wrapTcS :: TcM a > TcS a
 Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
 and TcS is supposed to have limited functionality
wrapTcS = TcS . const  a TcM action will not use the TcEvBinds
wrapErrTcS :: TcM a > TcS a
 The thing wrapped should just fail
 There's no static check; it's up to the user
 Having a variant for each error message is too painful
wrapErrTcS = wrapTcS
wrapWarnTcS :: TcM a > TcS a
 The thing wrapped should just add a warning, or noop
 There's no static check; it's up to the user
wrapWarnTcS = wrapTcS
failTcS, panicTcS :: SDoc > TcS a
warnTcS :: WarningFlag > SDoc > TcS ()
addErrTcS :: SDoc > TcS ()
failTcS = wrapTcS . TcM.failWith
warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)
addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "TcCanonical" doc
traceTcS :: String > SDoc > TcS ()
traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
runTcPluginTcS :: TcPluginM a > TcS a
runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar
instance HasDynFlags TcS where
getDynFlags = wrapTcS getDynFlags
getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv
bumpStepCountTcS :: TcS ()
bumpStepCountTcS = TcS $ \env > do { let ref = tcs_count env
; n < TcM.readTcRef ref
; TcM.writeTcRef ref (n+1) }
csTraceTcS :: SDoc > TcS ()
csTraceTcS doc
= wrapTcS $ csTraceTcM (return doc)
traceFireTcS :: CtEvidence > SDoc > TcS ()
 Dump a rulefiring trace
traceFireTcS ev doc
= TcS $ \env > csTraceTcM $
do { n < TcM.readTcRef (tcs_count env)
; tclvl < TcM.getTcLevel
; return (hang (text "Step" <+> int n
<> brackets (text "l:" <> ppr tclvl <> comma <>
text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))
<+> doc <> colon)
4 (ppr ev)) }
csTraceTcM :: TcM SDoc > TcM ()
 Constraintsolver tracing, ddumpcstrace
csTraceTcM mk_doc
= do { dflags < getDynFlags
; when ( dopt Opt_D_dump_cs_trace dflags
 dopt Opt_D_dump_tc_trace dflags )
( do { msg < mk_doc
; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }
runTcS :: TcS a  What to run
> TcM (a, EvBindMap)
runTcS tcs
= do { ev_binds_var < TcM.newTcEvBinds
; res < runTcSWithEvBinds ev_binds_var tcs
; ev_binds < TcM.getTcEvBindsMap ev_binds_var
; return (res, ev_binds) }
  This variant of 'runTcS' will keep solving, even when only Deriveds
 are left around. It also doesn't return any evidence, as callers won't
 need it.
runTcSDeriveds :: TcS a > TcM a
runTcSDeriveds tcs
= do { ev_binds_var < TcM.newTcEvBinds
; runTcSWithEvBinds ev_binds_var tcs }
  This can deal only with equality constraints.
runTcSEqualities :: TcS a > TcM a
runTcSEqualities thing_inside
= do { ev_binds_var < TcM.newNoTcEvBinds
; runTcSWithEvBinds ev_binds_var thing_inside }
runTcSWithEvBinds :: EvBindsVar
> TcS a
> TcM a
runTcSWithEvBinds ev_binds_var tcs
= do { unified_var < TcM.newTcRef 0
; step_count < TcM.newTcRef 0
; inert_var < TcM.newTcRef emptyInert
; wl_var < TcM.newTcRef emptyWorkList
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_unified = unified_var
, tcs_count = step_count
, tcs_inerts = inert_var
, tcs_worklist = wl_var }
 Run the computation
; res < unTcS tcs env
; count < TcM.readTcRef step_count
; when (count > 0) $
csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
; unflattenGivens inert_var
#if defined(DEBUG)
; ev_binds < TcM.getTcEvBindsMap ev_binds_var
; checkForCyclicBinds ev_binds
#endif
; return res }

#if defined(DEBUG)
checkForCyclicBinds :: EvBindMap > TcM ()
checkForCyclicBinds ev_binds_map
 null cycles
= return ()
 null coercion_cycles
= TcM.traceTc "Cycle in evidence binds" $ ppr cycles
 otherwise
= pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
where
ev_binds = evBindMapBinds ev_binds_map
cycles :: [[EvBind]]
cycles = [c  CyclicSCC c < stronglyConnCompFromEdgedVerticesUniq edges]
coercion_cycles = [c  c < cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
edges :: [ Node EvVar EvBind ]
edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
 bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) < bagToList ev_binds ]
 It's OK to use nonDetEltsUFM here as
 stronglyConnCompFromEdgedVertices is still deterministic even
 if the edges are in nondeterministic order as explained in
 Note [Deterministic SCC] in Digraph.
#endif

setEvBindsTcS :: EvBindsVar > TcS a > TcS a
setEvBindsTcS ref (TcS thing_inside)
= TcS $ \ env > thing_inside (env { tcs_ev_binds = ref })
nestImplicTcS :: EvBindsVar
> TcLevel > TcS a
> TcS a
nestImplicTcS ref inner_tclvl (TcS thing_inside)
= TcS $ \ TcSEnv { tcs_unified = unified_var
, tcs_inerts = old_inert_var
, tcs_count = count
} >
do { inerts < TcM.readTcRef old_inert_var
; let nest_inert = emptyInert { inert_cans = inert_cans inerts
, inert_solved_dicts = inert_solved_dicts inerts }
 See Note [Do not inherit the flat cache]
; new_inert_var < TcM.newTcRef nest_inert
; new_wl_var < TcM.newTcRef emptyWorkList
; let nest_env = TcSEnv { tcs_ev_binds = ref
, tcs_unified = unified_var
, tcs_count = count
, tcs_inerts = new_inert_var
, tcs_worklist = new_wl_var }
; res < TcM.setTcLevel inner_tclvl $
thing_inside nest_env
; unflattenGivens new_inert_var
#if defined(DEBUG)
 Perform a check that the thing_inside did not cause cycles
; ev_binds < TcM.getTcEvBindsMap ref
; checkForCyclicBinds ev_binds
#endif
; return res }
{ Note [Do not inherit the flat cache]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not want to inherit the flat cache when processing nested
implications. Consider
a ~ F b, forall c. b~Int => blah
If we have F b ~ fsk in the flatcache, and we push that into the
nested implication, we might miss that F b can be rewritten to F Int,
and hence perhpas solve it. Moreover, the fsk from outside is
flattened out after solving the outer level, but and we don't
do that flattening recursively.
}
nestTcS :: TcS a > TcS a
 Use the current untouchables, augmenting the current
 evidence bindings, and solved dictionaries
 But have no effect on the InertCans, or on the inert_flat_cache
 (we want to inherit the latter from processing the Givens)
nestTcS (TcS thing_inside)
= TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) >
do { inerts < TcM.readTcRef inerts_var
; new_inert_var < TcM.newTcRef inerts
; new_wl_var < TcM.newTcRef emptyWorkList
; let nest_env = env { tcs_inerts = new_inert_var
, tcs_worklist = new_wl_var }
; res < thing_inside nest_env
; new_inerts < TcM.readTcRef new_inert_var
 we want to propogate the safe haskell failures
; let old_ic = inert_cans inerts
new_ic = inert_cans new_inerts
nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }
; TcM.writeTcRef inerts_var  See Note [Propagate the solved dictionaries]
(inerts { inert_solved_dicts = inert_solved_dicts new_inerts
, inert_cans = nxt_ic })
; return res }
checkConstraintsTcS :: SkolemInfo
> [TcTyVar]  Skolems
> TcS result
> TcS result
 Just like TcUnify.checkTvConstraints, but in the TcS monnad,
 using the worklist to gather the constraints
checkConstraintsTcS skol_info skol_tvs (TcS thing_inside)
= TcS $ \ tcs_env >
do { new_wl_var < TcM.newTcRef emptyWorkList
; let new_tcs_env = tcs_env { tcs_worklist = new_wl_var }
; (res, new_tclvl) < TcM.pushTcLevelM $
thing_inside new_tcs_env
; wl@WL { wl_eqs = eqs } < TcM.readTcRef new_wl_var
; ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) &&
null (wl_implics wl), ppr wl )
unless (null eqs) $
do { tcl_env < TcM.getLclEnv
; ev_binds_var < TcM.newNoTcEvBinds
; let wc = WC { wc_simple = listToCts eqs
, wc_impl = emptyBag }
imp = newImplication { ic_tclvl = new_tclvl
, ic_skols = skol_tvs
, ic_wanted = wc
, ic_binds = ev_binds_var
, ic_env = tcl_env
, ic_info = skol_info }
 Add the implication to the worklist
; TcM.updTcRef (tcs_worklist tcs_env)
(extendWorkListImplic (unitBag imp)) }
; return res }
{
Note [Propagate the solved dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's really quite important that nestTcS does not discard the solved
dictionaries from the thing_inside.
Consider
Eq [a]
forall b. empty => Eq [a]
We solve the simple (Eq [a]), under nestTcS, and then turn our attention to
the implications. It's definitely fine to use the solved dictionaries on
the inner implications, and it can make a signficant performance difference
if you do so.
}
 Getters and setters of TcEnv fields
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Getter of inerts and worklist
getTcSInertsRef :: TcS (IORef InertSet)
getTcSInertsRef = TcS (return . tcs_inerts)
getTcSWorkListRef :: TcS (IORef WorkList)
getTcSWorkListRef = TcS (return . tcs_worklist)
getTcSInerts :: TcS InertSet
getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
setTcSInerts :: InertSet > TcS ()
setTcSInerts ics = do { r < getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) }
getWorkListImplics :: TcS (Bag Implication)
getWorkListImplics
= do { wl_var < getTcSWorkListRef
; wl_curr < wrapTcS (TcM.readTcRef wl_var)
; return (wl_implics wl_curr) }
updWorkListTcS :: (WorkList > WorkList) > TcS ()
updWorkListTcS f
= do { wl_var < getTcSWorkListRef
; wrapTcS (TcM.updTcRef wl_var f)}
emitWorkNC :: [CtEvidence] > TcS ()
emitWorkNC evs
 null evs
= return ()
 otherwise
= emitWork (map mkNonCanonical evs)
emitWork :: [Ct] > TcS ()
emitWork cts
= do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
; updWorkListTcS (extendWorkListCts cts) }
newTcRef :: a > TcS (TcRef a)
newTcRef x = wrapTcS (TcM.newTcRef x)
readTcRef :: TcRef a > TcS a
readTcRef ref = wrapTcS (TcM.readTcRef ref)
updTcRef :: TcRef a > (a>a) > TcS ()
updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
getTcEvBindsVar :: TcS EvBindsVar
getTcEvBindsVar = TcS (return . tcs_ev_binds)
getTcLevel :: TcS TcLevel
getTcLevel = wrapTcS TcM.getTcLevel
getTcEvTyCoVars :: EvBindsVar > TcS TyCoVarSet
getTcEvTyCoVars ev_binds_var
= wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
getTcEvBindsMap :: EvBindsVar > TcS EvBindMap
getTcEvBindsMap ev_binds_var
= wrapTcS $ TcM.getTcEvBindsMap ev_binds_var
setTcEvBindsMap :: EvBindsVar > EvBindMap > TcS ()
setTcEvBindsMap ev_binds_var binds
= wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds
unifyTyVar :: TcTyVar > TcType > TcS ()
 Unify a metatyvar with a type
 We keep track of how many unifications have happened in tcs_unified,

 We should never unify the same variable twice!
unifyTyVar tv ty
= ASSERT2( isMetaTyVar tv, ppr tv )
TcS $ \ env >
do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
; TcM.writeMetaTyVar tv ty
; TcM.updTcRef (tcs_unified env) (+1) }
reportUnifications :: TcS a > TcS (Int, a)
reportUnifications (TcS thing_inside)
= TcS $ \ env >
do { inner_unified < TcM.newTcRef 0
; res < thing_inside (env { tcs_unified = inner_unified })
; n_unifs < TcM.readTcRef inner_unified
; TcM.updTcRef (tcs_unified env) (+ n_unifs)
; return (n_unifs, res) }
getDefaultInfo :: TcS ([Type], (Bool, Bool))
getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
 Just get some environments needed for instance looking up and matching
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getInstEnvs :: TcS InstEnvs
getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
getTopEnv :: TcS HscEnv
getTopEnv = wrapTcS $ TcM.getTopEnv
getGblEnv :: TcS TcGblEnv
getGblEnv = wrapTcS $ TcM.getGblEnv
getLclEnv :: TcS TcLclEnv
getLclEnv = wrapTcS $ TcM.getLclEnv
tcLookupClass :: Name > TcS Class
tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
tcLookupId :: Name > TcS Id
tcLookupId n = wrapTcS $ TcM.tcLookupId n
 Setting names as used (used in the deriving of Coercible evidence)
 Too hackish to expose it to TcS? In that case somehow extract the used
 constructors from the result of solveInteract
addUsedGREs :: [GlobalRdrElt] > TcS ()
addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres
addUsedGRE :: Bool > GlobalRdrElt > TcS ()
addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
 Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
checkWellStagedDFun :: PredType > DFunId > CtLoc > TcS ()
checkWellStagedDFun pred dfun_id loc
= wrapTcS $ TcM.setCtLocM loc $
do { use_stage < TcM.getStage
; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
where
pp_thing = text "instance for" <+> quotes (ppr pred)
bind_lvl = TcM.topIdLvl dfun_id
pprEq :: TcType > TcType > SDoc
pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
isFilledMetaTyVar_maybe :: TcTyVar > TcS (Maybe Type)
isFilledMetaTyVar_maybe tv
= case tcTyVarDetails tv of
MetaTv { mtv_ref = ref }
> do { cts < wrapTcS (TcM.readTcRef ref)
; case cts of
Indirect ty > return (Just ty)
Flexi > return Nothing }
_ > return Nothing
isFilledMetaTyVar :: TcTyVar > TcS Bool
isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
zonkTyCoVarsAndFV :: TcTyCoVarSet > TcS TcTyCoVarSet
zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)
zonkTyCoVarsAndFVList :: [TcTyCoVar] > TcS [TcTyCoVar]
zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)
zonkCo :: Coercion > TcS Coercion
zonkCo = wrapTcS . TcM.zonkCo
zonkTcType :: TcType > TcS TcType
zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
zonkTcTypes :: [TcType] > TcS [TcType]
zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)
zonkTcTyVar :: TcTyVar > TcS TcType
zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
zonkSimples :: Cts > TcS Cts
zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
zonkWC :: WantedConstraints > TcS WantedConstraints
zonkWC wc = wrapTcS (TcM.zonkWC wc)
zonkTcTyCoVarBndr :: TcTyCoVar > TcS TcTyCoVar
zonkTcTyCoVarBndr tv = wrapTcS (TcM.zonkTcTyCoVarBndr tv)
{ *********************************************************************
* *
* Flatten skolems *
* *
********************************************************************* }
newFlattenSkolem :: CtFlavour > CtLoc
> TyCon > [TcType]  F xis
> TcS (CtEvidence, Coercion, TcTyVar)  [G/WD] x:: F xis ~ fsk
newFlattenSkolem flav loc tc xis
= do { stuff@(ev, co, fsk) < new_skolem
; let fsk_ty = mkTyVarTy fsk
; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
; return stuff }
where
fam_ty = mkTyConApp tc xis
new_skolem
 Given < flav
= do { fsk < wrapTcS (TcM.newFskTyVar fam_ty)
 Extend the inert_fsks list, for use by unflattenGivens
; updInertTcS $ \is > is { inert_fsks = (fsk, fam_ty) : inert_fsks is }
 Construct the Refl evidence
; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
co = mkNomReflCo fam_ty
; ev < newGivenEvVar loc (pred, evCoercion co)
; return (ev, co, fsk) }
 otherwise  Generate a [WD] for both Wanted and Derived
 See Note [No Derived CFunEqCans]
= do { fmv < wrapTcS (TcM.newFmvTyVar fam_ty)
; (ev, hole_co) < newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)
; return (ev, hole_co, fmv) }

unflattenGivens :: IORef InertSet > TcM ()
 Unflatten all the fsks created by flattening types in Given
 constraints. We must be sure to do this, else we end up with
 flattenskolems buried in any residual Wanteds

 NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
 is filled in. Nothing else does so.

 It's here (rather than in TcFlatten) because the Right Places
 to call it are in runTcSWithEvBinds/nestImplicTcS, where it
 is nicely paired with the creation an empty inert_fsks list.
unflattenGivens inert_var
= do { inerts < TcM.readTcRef inert_var
; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
; mapM_ flatten_one (inert_fsks inerts) }
where
flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty

extendFlatCache :: TyCon > [Type] > (TcCoercion, TcType, CtFlavour) > TcS ()
extendFlatCache tc xi_args stuff@(_, ty, fl)
 isGivenOrWDeriv fl  Maintain the invariant that inert_flat_cache
 only has [G] and [WD] CFunEqCans
= do { dflags < getDynFlags
; when (gopt Opt_FlatCache dflags) $
do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args
, ppr fl, ppr ty ])
 'co' can be bottom, in the case of derived items
; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) >
is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }
 otherwise
= return ()

unflattenFmv :: TcTyVar > TcType > TcS ()
 Fill a flattenmetavar, simply by unifying it.
 This does NOT count as a unification in tcs_unified.
unflattenFmv tv ty
= ASSERT2( isMetaTyVar tv, ppr tv )
TcS $ \ _ >
do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
; TcM.writeMetaTyVar tv ty }

demoteUnfilledFmv :: TcTyVar > TcS ()
 If a flattenmetavar is still unfilled,
 turn it into an ordinary metavar
demoteUnfilledFmv fmv
= wrapTcS $ do { is_filled < TcM.isFilledMetaTyVar fmv
; unless is_filled $
do { tv_ty < TcM.newFlexiTyVarTy (tyVarKind fmv)
; TcM.writeMetaTyVar fmv tv_ty } }

dischargeFmv :: CtEvidence > TcTyVar > TcCoercion > TcType > TcS ()
 (dischargeFmv ev fmv co ty)
 [W] ev :: F tys ~ fmv
 co :: F tys ~ xi
 Precondition: fmv is not filled, and fmv `notElem` xi
 ev is Wanted or Derived
+dischargeFunEq :: CtEvidence > TcTyVar > TcCoercion > TcType > TcS ()
+ (dischargeFunEqCan ev tv co ty)
+ Preconditions
+  ev :: F tys ~ tv is a CFunEqCan
+  tv is a FlatMetaTv of FlatSkolTv
+  co :: F tys ~ xi
+  fmv/fsk `notElem` xi
+  fmv not filled (for Wanteds)

 Then for [W] or [WD], we actually fill in the fmv:
 set fmv := xi,
 set ev := co
 kick out any inert things that are now rewritable

 For [D], we instead emit an equality that must ultimately hold
 emit xi ~ fmv
+ [D] xi ~ fmv
 Does not evaluate 'co' if 'ev' is Derived

+ For [G], emit this equality
+ [G] (sym ev; co) :: fsk ~ xi
+
 See TcFlatten Note [The flattening story],
 especially "Ownership of fsk/fmv"
dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi
+dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
+ = do { new_ev < newGivenEvVar loc ( new_pred, evCoercion new_co )
+ ; emitWorkNC [new_ev] }
+ where
+ new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
+ new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
+
+dischargeFunEq 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 (CtDerived { ctev_loc = loc }) fmv _co xi
+dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
= emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
 FunEqs are always at Nominal role
dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev)

pprKicked :: Int > SDoc
pprKicked 0 = empty
pprKicked n = parens (int n <+> text "kicked out")
{ *********************************************************************
* *
* Instantiation etc.
* *
********************************************************************* }
 Instantiations
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
instDFunType :: DFunId > [DFunInstType] > TcS ([TcType], TcThetaType)
instDFunType dfun_id inst_tys
= wrapTcS $ TcM.instDFunType dfun_id inst_tys
newFlexiTcSTy :: Kind > TcS TcType
newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
cloneMetaTyVar :: TcTyVar > TcS TcTyVar
cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
instFlexi :: [TKVar] > TcS TCvSubst
instFlexi = instFlexiX emptyTCvSubst
instFlexiX :: TCvSubst > [TKVar] > TcS TCvSubst
instFlexiX subst tvs
= wrapTcS (foldlM instFlexiHelper subst tvs)
instFlexiHelper :: TCvSubst > TKVar > TcM TCvSubst
instFlexiHelper subst tv
= do { uniq < TcM.newUnique
; details < TcM.newMetaDetails TauTv
; let name = setNameUnique (tyVarName tv) uniq
kind = substTyUnchecked subst (tyVarKind tv)
ty' = mkTyVarTy (mkTcTyVar name kind details)
; TcM.traceTc "instFlexi" (ppr ty')
; return (extendTvSubst subst tv ty') }
tcInstType :: ([TyVar] > TcM (TCvSubst, [TcTyVar]))
 ^ How to instantiate the type variables
> Id  ^ Type to instantiate
> TcS ([(Name, TcTyVar)], TcThetaType, TcType)  ^ Result
 (type vars, preds (incl equalities), rho)
tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id)
tcInstSkolTyVarsX :: TCvSubst > [TyVar] > TcS (TCvSubst, [TcTyVar])
tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
 Creating and setting evidence variables and CtFlavors
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data MaybeNew = Fresh CtEvidence  Cached EvExpr
isFresh :: MaybeNew > Bool
isFresh (Fresh {}) = True
isFresh (Cached {}) = False
freshGoals :: [MaybeNew] > [CtEvidence]
freshGoals mns = [ ctev  Fresh ctev < mns ]
getEvExpr :: MaybeNew > EvExpr
getEvExpr (Fresh ctev) = ctEvExpr ctev
getEvExpr (Cached evt) = evt
setEvBind :: EvBind > TcS ()
setEvBind ev_bind
= do { evb < getTcEvBindsVar
; wrapTcS $ TcM.addTcEvBind evb ev_bind }
  Mark variables as used filling a coercion hole
useVars :: CoVarSet > TcS ()
useVars vars
= do { ev_binds_var < getTcEvBindsVar
; let ref = ebv_tcvs ev_binds_var
; wrapTcS $
do { tcvs < TcM.readTcRef ref
; let tcvs' = tcvs `unionVarSet` vars
; TcM.writeTcRef ref tcvs' } }
  Equalities only
setWantedEq :: TcEvDest > Coercion > TcS ()
setWantedEq (HoleDest hole) co
= do { useVars (coVarsOfCo co)
; wrapTcS $ TcM.fillCoercionHole hole co }
setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)
  Equalities only
setEqIfWanted :: CtEvidence > Coercion > TcS ()
setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co
setEqIfWanted _ _ = return ()
  Good for equalities and nonequalities
setWantedEvTerm :: TcEvDest > EvTerm > TcS ()
setWantedEvTerm (HoleDest hole) tm
= do { let co = evTermCoercion tm
; useVars (coVarsOfCo co)
; wrapTcS $ TcM.fillCoercionHole hole co }
setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm
setWantedEvBind :: EvVar > EvTerm > TcS ()
setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm)
setEvBindIfWanted :: CtEvidence > EvExpr > TcS ()
setEvBindIfWanted ev tm
= case ev of
CtWanted { ctev_dest = dest }
> setWantedEvTerm dest (EvExpr tm)
_ > return ()
newTcEvBinds :: TcS EvBindsVar
newTcEvBinds = wrapTcS TcM.newTcEvBinds
newNoTcEvBinds :: TcS EvBindsVar
newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
newEvVar :: TcPredType > TcS EvVar
newEvVar pred = wrapTcS (TcM.newEvVar pred)
newGivenEvVar :: CtLoc > (TcPredType, EvExpr) > TcS CtEvidence
 Make a new variable of the given PredType,
 immediately bind it to the given term
 and return its CtEvidence
 See Note [Bind new Givens immediately] in TcRnTypes
newGivenEvVar loc (pred, rhs)
= do { new_ev < newBoundEvVarId pred rhs
; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
  Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the
 given term
newBoundEvVarId :: TcPredType > EvExpr > TcS EvVar
newBoundEvVarId pred rhs
= do { new_ev < newEvVar pred
; setEvBind (mkGivenEvBind new_ev rhs)
; return new_ev }
newGivenEvVars :: CtLoc > [(TcPredType, EvExpr)] > TcS [CtEvidence]
newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
emitNewWantedEq :: CtLoc > Role > TcType > TcType > TcS Coercion
  Emit a new Wanted equality into the worklist
emitNewWantedEq loc role ty1 ty2
 otherwise
= do { (ev, co) < newWantedEq loc role ty1 ty2
; updWorkListTcS $
extendWorkListEq (mkNonCanonical ev)
; return co }
  Make a new equality CtEvidence
newWantedEq :: CtLoc > Role > TcType > TcType > TcS (CtEvidence, Coercion)
newWantedEq loc role ty1 ty2
= do { hole < wrapTcS $ TcM.newCoercionHole pty
; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
, ctev_nosh = WDeriv
, ctev_loc = loc}
, mkHoleCo hole ) }
where
pty = mkPrimEqPredRole role ty1 ty2
 no equalities here. Use newWantedEq instead
newWantedEvVarNC :: CtLoc > TcPredType > TcS CtEvidence
 Don't look up in the solved/inerts; we know it's not there
newWantedEvVarNC loc pty
= do { new_ev < newEvVar pty
; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
pprCtLoc loc)
; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev
, ctev_nosh = WDeriv
, ctev_loc = loc })}
newWantedEvVar :: CtLoc > TcPredType > TcS MaybeNew
 For anything except ClassPred, this is the same as newWantedEvVarNC
newWantedEvVar loc pty
= do { mb_ct < lookupInInerts loc pty
; case mb_ct of
Just ctev
 not (isDerived ctev)
> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
; return $ Cached (ctEvExpr ctev) }
_ > do { ctev < newWantedEvVarNC loc pty
; return (Fresh ctev) } }
 deals with both equalities and non equalities. Tries to look
 up nonequalities in the cache
newWanted :: CtLoc > PredType > TcS MaybeNew
newWanted loc pty
 Just (role, ty1, ty2) < getEqPredTys_maybe pty
= Fresh . fst <$> newWantedEq loc role ty1 ty2
 otherwise
= newWantedEvVar loc pty
 deals with both equalities and non equalities. Doesn't do any cache lookups.
newWantedNC :: CtLoc > PredType > TcS CtEvidence
newWantedNC loc pty
 Just (role, ty1, ty2) < getEqPredTys_maybe pty
= fst <$> newWantedEq loc role ty1 ty2
 otherwise
= newWantedEvVarNC loc pty
emitNewDeriveds :: CtLoc > [TcPredType] > TcS ()
emitNewDeriveds loc preds
 null preds
= return ()
 otherwise
= do { evs < mapM (newDerivedNC loc) preds
; traceTcS "Emitting new deriveds" (ppr evs)
; updWorkListTcS (extendWorkListDeriveds evs) }
emitNewDerivedEq :: CtLoc > Role > TcType > TcType > TcS ()
 Create new equality Derived and put it in the work list
 There's no caching, no lookupInInerts
emitNewDerivedEq loc role ty1 ty2
= do { ev < newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)
; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)
; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }
 Very important: put in the wl_eqs
 See Note [Prioritise equalities] (Avoiding fundep iteration)
newDerivedNC :: CtLoc > TcPredType > TcS CtEvidence
newDerivedNC loc pred
= do {  checkReductionDepth loc pred
; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }
  Check done in TcInteract.selectNewWorkItem???? 
  Checks if the depth of the given location is too much. Fails if
 it's too big, with an appropriate error message.
checkReductionDepth :: CtLoc > TcType  ^ type being reduced
> TcS ()
checkReductionDepth loc ty
= do { dflags < getDynFlags
; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $
wrapErrTcS $
solverDepthErrorTcS loc ty }
matchFam :: TyCon > [Type] > TcS (Maybe (Coercion, TcType))
matchFam tycon args = wrapTcS $ matchFamTcM tycon args
matchFamTcM :: TyCon > [Type] > TcM (Maybe (Coercion, TcType))
 Given (F tys) return (ty, co), where co :: F tys ~ ty
matchFamTcM tycon args
= do { fam_envs < FamInst.tcGetFamInstEnvs
; let match_fam_result
= reduceTyFamApp_maybe fam_envs Nominal tycon args
; TcM.traceTc "matchFamTcM" $
vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)
, ppr_res match_fam_result ]
; return match_fam_result }
where
ppr_res Nothing = text "Match failed"
ppr_res (Just (co,ty)) = hang (text "Match succeeded:")
2 (vcat [ text "Rewrites to:" <+> ppr ty
, text "Coercion:" <+> ppr co ])
{
Note [Residual implications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The wl_implics in the WorkList are the residual implication
constraints that are generated while solving or canonicalising the
current worklist. Specifically, when canonicalising
(forall a. t1 ~ forall a. t2)
from which we get the implication
(forall a. t1 ~ t2)
See TcSMonad.deferTcSForAllEq
}
diff git a/testsuite/tests/indexedtypes/should_compile/T15122.hs b/testsuite/tests/indexedtypes/should_compile/T15122.hs
new file mode 100644
index 0000000..44a3c05
 /dev/null
+++ b/testsuite/tests/indexedtypes/should_compile/T15122.hs
@@ 0,0 +1,16 @@
+{# LANGUAGE GADTs #}
+{# LANGUAGE TypeFamilies #}
+{# LANGUAGE TypeInType #}
+module T15122 where
+
+import Data.Kind
+import Data.Proxy
+
+data IsStar (a :: k) where
+ IsStar :: IsStar (a :: *)
+
+type family F (a :: k) :: k
+
+foo :: (F a ~ F b) => IsStar a > Proxy b
+ > Proxy (F a) > Proxy (F b)
+foo IsStar _ p = p
diff git a/testsuite/tests/indexedtypes/should_compile/all.T b/testsuite/tests/indexedtypes/should_compile/all.T
index 9f0d9b4..5a6ae27 100644
 a/testsuite/tests/indexedtypes/should_compile/all.T
+++ b/testsuite/tests/indexedtypes/should_compile/all.T
@@ 1,283 +1,284 @@
test('Simple1', normal, compile, [''])
test('Simple2', normal, compile, [''])
test('Simple3', normal, compile, [''])
test('Simple4', normal, compile, [''])
test('Simple5', normal, compile, [''])
test('Simple6', normal, compile, [''])
test('Simple7', normal, compile, [''])
test('Simple8', normal, compile, [''])
test('Simple9', normal, compile, [''])
test('Simple10', normal, compile, [''])
test('Simple11', normal, compile, [''])
test('Simple12', normal, compile, [''])
test('Simple13', normal, compile, [''])
test('Simple14', normal, compile_fail, [''])
test('Simple15', normal, compile, [''])
test('Simple16', normal, compile, [''])
test('Simple17', normal, compile, [''])
test('Simple18', normal, compile, [''])
test('Simple19', normal, compile, [''])
test('Simple20', expect_broken(4296), compile, ['fcontextstack=10'])
test('Simple21', normal, compile, [''])
test('Simple22', normal, compile, [''])
test('Simple23', normal, compile, [''])
test('Simple24', normal, compile, [''])
test('RelaxedExamples', normal, compile, [''])
test('NonLinearLHS', normal, compile, [''])
test('ind1', normal, compile, [''])
test('ind2', [extra_files(['Ind2_help.hs'])], multimod_compile, ['ind2', 'v0'])
test('impexp', [extra_files(['Exp.hs', 'Imp.hs'])], multimod_compile, ['Imp', 'w nohsmain c'])
test('ATLoop', [], multimod_compile, ['ATLoop.hs', 'v0'])
test('Deriving', normal, compile, [''])
test('DerivingNewType', normal, compile, [''])
test('Records', normal, compile, [''])
# The point about this test is that it compiles NewTyCo1 and NewTyCo2
# *separately*
#
test('NewTyCo', [], run_command, ['$MAKE s noprintdirectory NewTyCo'])
test('Infix', normal, compile, [''])
test('Kind', normal, compile, [''])
test('GADT1', normal, compile, [''])
test('GADT2', normal, compile, [''])
test('GADT3', normal, compile, [''])
test('GADT4', normal, compile, [''])
test('GADT5', normal, compile, [''])
test('GADT6', normal, compile, [''])
test('GADT7', normal, compile, [''])
test('GADT8', normal, compile, [''])
test('GADT9', normal, compile, [''])
test('GADT10', normal, compile, [''])
test('GADT11', normal, compile, [''])
test('GADT12', normal, compile, [''])
test('GADT13', normal, compile, [''])
test('GADT14', normal, compile, [''])
test('Class1', normal, compile, [''])
test('Class2', normal, compile, [''])
test('Class3', normal, compile, [''])
test('Refl', normal, compile, [''])
test('Refl2', normal, compile, [''])
test('Rules1', normal, compile, [''])
test('Numerals', normal, compile, [''])
test('ColInference', normal, compile, [''])
test('ColInference2', normal, compile, [''])
test('ColInference3', normal, compile, [''])
test('ColInference4', normal, compile, [''])
test('ColInference5', normal, compile, [''])
test('ColInference6', normal, compile, [''])
test('Col', normal, compile, [''])
test('Col2', normal, compile, [''])
test('ColGivenCheck', normal, compile, [''])
test('ColGivenCheck2', normal, compile, [''])
test('InstEqContext', normal, compile, [''])
test('InstEqContext2', normal, compile, [''])
test('InstEqContext3', normal, compile, [''])
test('InstContextNorm', normal, compile, [''])
test('GivenCheck', normal, compile, [''])
test('GivenCheckSwap', normal, compile, [''])
test('GivenCheckDecomp', normal, compile, [''])
test('GivenCheckTop', normal, compile, [''])
# A very delicate test
test('Gentle', normal, compile, [''])
test('T1981', normal, compile, [''])
test('T2238', normal, compile, [''])
test('OversatDecomp', normal, compile, [''])
test('T2219', normal, compile, [''])
test('T2627', normal, compile, [''])
test('T2448', normal, compile, [''])
test('T2291', normal, compile, [''])
test('T2639', normal, compile, [''])
test('T2944', normal, compile, [''])
test('T3017', normal, compile, ['ddumptypes'])
test('TF_GADT', normal, compile, [''])
test('T2203b', normal, compile, [''])
test('T2767', normal, compile, [''])
test('T3208a', normal, compile, [''])
test('T3208b', normal, compile_fail, [''])
test('T3418', normal, compile, [''])
test('T3423', normal, compile, [''])
test('T2850', normal, compile, [''])
test('T3220', normal, compile, [''])
test('T3590', normal, compile, [''])
test('CoTest3', normal, compile, [''])
test('Roman1', normal, compile, [''])
test('T4160', normal, compile, [''])
test('IndTypesPerf',
[ # expect_broken(5224),
# unbroken temporarily: #5227
extra_clean(['IndTypesPerf.o', 'IndTypesPerf.hi',
'IndTypesPerfMerge.o', 'IndTypesPerfMerge.hi'])
] ,
run_command,
['$MAKE s noprintdirectory IndTypesPerf'])
test('T4120', normal, compile, [''])
test('T3787', normal, compile, [''])
test('T3826', normal, compile, [''])
test('T4200', normal, compile, [''])
test('T3851', normal, compile, [''])
test('T4178', normal, compile, [''])
test('T3023', normal, compile, [''])
test('T4358', normal, compile, [''])
test('T4356', normal, compile, [''])
test('T4484', normal, compile, [''])
test('T4492', normal, compile, [''])
test('T4494', normal, compile, [''])
test('DataFamDeriv', normal, compile, [''])
test('T1769', normal, compile, [''])
test('T4497', normal, compile, [''])
test('T3484', normal, compile, [''])
test('T3460', normal, compile, [''])
test('T4935', normal, compile, [''])
test('T4981V1', normal, compile, [''])
test('T4981V2', normal, compile, [''])
test('T4981V3', normal, compile, [''])
test('T5002', normal, compile, [''])
test('PushedInAsGivens', normal, compile_fail, [''])
# Superclass equalities
test('T4338', normal, compile, [''])
test('T2715', normal, compile, [''])
test('T2102', normal, compile, [''])
test('ClassEqContext', normal, compile, [''])
test('ClassEqContext2', normal, compile, [''])
test('ClassEqContext3', normal, compile, [''])
test('HO', normal, compile, [''])
# The point about this test is that it compiles the two T5955
# modules *separately*
test('T5955', [], run_command, ['$MAKE s noprintdirectory T5955'])
test('T6152',
normal,
run_command,
['$MAKE s noprintdirectory T6152'])
test('T7082', normal, compile, [''])
test('Overlap1', normal, compile, [''])
test('Overlap2', normal, compile, [''])
test('Overlap12', normal, compile, [''])
test('Overlap13', normal, compile, [''])
test('Overlap14', normal, compile, [''])
test('T7156', normal, compile, [''])
test('T5591a', normal, compile, [''])
test('T5591b', normal, compile, [''])
test('T6088', normal, compile, [''])
test('T7280', normal, compile, [''])
test('T7474', normal, compile, [''])
test('T7489', normal, compile, [''])
test('T7585', normal, compile, [''])
test('T7282', normal, compile, [''])
test('T7804', normal, compile, [''])
# This test has sometimes been marked as
# expect_broken_for(9406, prof_ways),
# so ticket #9406 can be used to track
# future failures as well.
test('T7837', normal, compile,
['O ddumprulefirings'])
test('T4185', normal, compile, [''])
# Caused infinite loop in the compiler
test('T8002',
normal,
run_command,
['$MAKE s noprintdirectory T8002'])
# Import and export of associated types
test('T8011',
normal,
run_command,
['$MAKE s noprintdirectory T8011'])
# Marshalling of associated types
test('T8500',
normal,
run_command,
['$MAKE s noprintdirectory T8500'])
test('T8018', normal, compile, [''])
test('T8020', normal, compile, [''])
test('ClosedFam1', [], multimod_compile, ['ClosedFam1', 'v0'])
test('ClosedFam2', [], multimod_compile, ['ClosedFam2', 'v0'])
test('T8651', normal, compile, [''])
test('T8889', normal, compile, [''])
test('T8913', normal, compile, [''])
test('T8978', normal, compile, [''])
test('T8979', normal, compile, [''])
test('T9085', normal, compile, [''])
test('T9316', normal, compile, [''])
test('redblackdelete', normal, compile, [''])
test('Sock', normal, compile, [''])
test('T9211', normal, compile, [''])
test('T9747', normal, compile, [''])
test('T9582', normal, compile, [''])
test('T9840', [], multimod_compile, ['T9840', 'v0'])
test('T9090', normal, compile, [''])
test('T10020', normal, compile, [''])
test('T10079', normal, compile, [''])
test('T10139', normal, compile, [''])
test('T10340', normal, compile, [''])
test('T10226', normal, compile, [''])
test('T10507', normal, compile, [''])
test('T10634', normal, compile, [''])
test('T10713', normal, compile, [''])
test('T10753', normal, compile, [''])
test('T10806', normal, compile_fail, [''])
test('T10815', normal, compile, [''])
test('T10931', normal, compile, [''])
test('T11187', normal, compile, [''])
test('T11067', normal, compile, [''])
test('T10318', normal, compile, [''])
test('UnusedTyVarWarnings', normal, compile, ['Wunusedtypepatterns'])
test('UnusedTyVarWarningsNamedWCs', normal, compile, ['Wunusedtypepatterns'])
test('T11408', normal, compile, [''])
test('T11361', normal, compile, ['duniqueincrement=1'])
# duniqueincrement=1 doesn't work inside the file
test('T11361a', normal, compile_fail, [''])
test('T11581', normal, compile, [''])
test('T12175', normal, compile, [''])
test('T12522', normal, compile, [''])
test('T12522b', normal, compile, [''])
test('T12676', normal, compile, [''])
test('T12526', normal, compile, [''])
test('T12538', normal, compile_fail, [''])
test('T13244', normal, compile, [''])
test('T13398a', normal, compile, [''])
test('T13398b', normal, compile, [''])
test('T13662', normal, compile, [''])
test('T13705', normal, compile, [''])
test('T12369', normal, compile, [''])
test('T14045', normal, compile, [''])
test('T12938', normal, compile, [''])
test('T14131', normal, compile, [''])
test('T14162', normal, compile, [''])
test('T14237', normal, compile, [''])
test('T14554', normal, compile, [''])
test('T14680', normal, compile, [''])
test('T15057', normal, compile, [''])
test('T15144', normal, compile, [''])
+test('T15122', normal, compile, [''])