Commit 6eabb6dd authored by Simon Peyton Jones's avatar Simon Peyton Jones

Allow recursive (undecidable) superclasses

This patch fulfils the request in Trac #11067, #10318, and #10592,
by lifting the conservative restrictions on superclass constraints.

These restrictions are there (and have been since Haskell was born) to
ensure that the transitive superclasses of a class constraint is a finite
set.  However (a) this restriction is conservative, and can be annoying
when there really is no recursion, and (b) sometimes genuinely recursive
superclasses are useful (see the tickets).

Dimitrios and I worked out that there is actually a relatively simple way
to do the job. It’s described in some detail in

   Note [The superclass story] in TcCanonical
   Note [Expanding superclasses] in TcType

In brief, the idea is to expand superclasses only finitely, but to
iterate (using a loop that already existed) if there are more
superclasses to explore.

Other small things

- I improved grouping of error messages a bit in TcErrors

- I re-centred the haddock.compiler test, which was at 9.8%
  above the norm, and which this patch pushed slightly over
parent b8ca6459
......@@ -565,6 +565,7 @@ data ExtensionFlag
| Opt_OverlappingInstances
| Opt_UndecidableInstances
| Opt_IncoherentInstances
| Opt_UndecidableSuperClasses
| Opt_MonomorphismRestriction
| Opt_MonoPatBinds
| Opt_MonoLocalBinds
......@@ -3261,6 +3262,7 @@ xFlags = [
flagSpec "TypeSynonymInstances" Opt_TypeSynonymInstances,
flagSpec "UnboxedTuples" Opt_UnboxedTuples,
flagSpec "UndecidableInstances" Opt_UndecidableInstances,
flagSpec "UndecidableSuperClasses" Opt_UndecidableSuperClasses,
flagSpec "UnicodeSyntax" Opt_UnicodeSyntax,
flagSpec "UnliftedFFITypes" Opt_UnliftedFFITypes,
flagSpec "ViewPatterns" Opt_ViewPatterns
......
......@@ -3,7 +3,7 @@
module TcCanonical(
canonicalize,
unifyDerived,
makeSuperClasses, mkGivensWithSuperClasses,
StopOrContinue(..), stopWith, continueWith
) where
......@@ -27,6 +27,7 @@ import OccName( OccName )
import Outputable
import DynFlags( DynFlags )
import VarSet
import NameSet
import RdrName
import Pair
......@@ -147,11 +148,11 @@ canonicalize ct@(CNonCanonical { cc_ev = ev })
; {-# SCC "canEvVar" #-}
canEvNC ev }
canonicalize (CDictCan { cc_ev = ev
, cc_class = cls
, cc_tyargs = xis })
canonicalize (CDictCan { cc_ev = ev, cc_class = cls
, cc_tyargs = xis, cc_pend_sc = pend_sc })
= {-# SCC "canClass" #-}
canClass ev cls xis -- Do not add any superclasses
canClass ev cls xis pend_sc
canonicalize (CTyEqCan { cc_ev = ev
, cc_tyvar = tv
, cc_rhs = xi
......@@ -191,59 +192,118 @@ canEvNC ev
************************************************************************
-}
canClass, canClassNC
:: CtEvidence
-> Class -> [Type] -> TcS (StopOrContinue Ct)
canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
canClassNC ev cls tys = canClass ev cls tys (has_scs cls)
where
has_scs cls = not (null (classSCTheta cls))
-- The canClassNC version is used on non-canonical constraints
-- and adds superclasses. The plain canClass version is used
-- for already-canonical class constraints (but which might have
-- been subsituted or somthing), and hence do not need superclasses
canClassNC ev cls tys
= canClass ev cls tys
`andWhenContinue` emitSuperclasses
canClass :: CtEvidence -> Class -> [Type] -> Bool -> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
canClass ev cls tys
canClass ev cls tys pend_sc
= -- all classes do *nominal* matching
ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
do { (xis, cos) <- flattenManyNom ev tys
; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
xi = mkClassPred cls xis
mk_ct new_ev = CDictCan { cc_ev = new_ev
, cc_tyargs = xis, cc_class = cls }
, 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) }
emitSuperclasses :: Ct -> TcS (StopOrContinue Ct)
emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls })
-- Add superclasses of this one here, See Note [Adding superclasses].
-- But only if we are not simplifying the LHS of a rule.
= do { newSCWorkFromFlavored ev cls xis_new
-- Arguably we should "seq" the coercions if they are derived,
-- as we do below for emit_kind_constraint, to allow errors in
-- superclasses to be executed if deferred to runtime!
; continueWith ct }
emitSuperclasses _ = panic "emit_superclasses of non-class!"
{- Note [Adding superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since dictionaries are canonicalized only once in their lifetime, the
place to add their superclasses is canonicalisation. See Note [Add
superclasses only during canonicalisation]. Here is what we do:
Givens: Add all their superclasses as Givens.
They may be needed to prove Wanteds.
Wanteds/Derived:
Add all their superclasses as Derived.
The sole reason is to expose functional dependencies
in superclasses or equality superclasses.
Examples of how adding superclasses as Derived is useful
{- Note [The superclass story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to add superclass constraints for two reasons:
* For givens, they give us a route to 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, 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 Wanted 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 generateing a Derived (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 real-life 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. Generate superclasses for given (but not wanted) constraints;
see Note [Aggressively expand given superclasses]. However
stop if you encounter the same class twice. That is, expand
eagerly, but have a conservative termination condition: see
Note [Expanding superclasses] in TcType.
2. Solve the wanteds as usual, but do /no/ expansion of superclasses
in solveSimpleGivens or solveSimpleWanteds.
See Note [Danger of adding superclasses during solving]
3. If we have any remaining unsolved wanteds, try harder:
take both the Givens and Wanteds, and expand superclasses again.
This may succeed in generating (a finite number of) extra Givens,
and extra Deriveds. Both may help the proof.
This is done in TcSimplify.expandSuperClasses.
4. Go round to (2) again. This loop (2,3,4) is implemented
in TcSimplify.simpl_loop.
We try to terminate the loop by flagging which class constraints
(given or wanted) are potentially un-expanded. This is what the
cc_pend_sc flag is for in CDictCan. So in Step 3 we only expand
superclasses for constraints with cc_pend_sc set to true (i.e.
isPendingScDict holds).
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 [Aggressively expand given superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In step (1) of Note [The superclass story], why do we aggressively
expand Given superclasses by one layer? 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 non-confluent proofs, but to stop our users
complaining we expand one layer in advance.
Note [Why adding superclasses can help]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Examples of how adding superclasses can help:
--- Example 1
class C a b | a -> b
......@@ -280,34 +340,8 @@ Examples of how adding superclasses as Derived is useful
[D] beta ~ b
which is what we want.
---------- Historical note -----------
Example of why adding superclass of a Wanted as a Given would
be terrible, see Note [Do not add superclasses of solved dictionaries]
in TcSMonad, which has this example:
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]
If we (bogusly) added the superclass of d2 as Given we'd have
[G] d1 : Ord a
[W] d2 : C [a]
[G] d3 : Ord [a] -- Superclass of d2, bogus
Then we'll use the instance decl to give
[G] d1 : Ord a Solved: d2 : C [a] = $dfCList d4
[G] d3 : Ord [a] -- Superclass of d2, bogus
[W] d4: Ord [a]
And now we could bogusly solve d4 from d3.
---------- End of historical note -----------
Note [Add superclasses only during canonicalisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add superclasses only during canonicalisation, on the passage
from CNonCanonical to CDictCan. A class constraint can be repeatedly
rewritten, and there's no point in repeatedly adding its superclasses.
Note [Danger of adding superclasses during solving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a serious, but now out-dated example, from Trac #4497:
class Num (RealOf t) => Normed t
......@@ -334,27 +368,70 @@ Mind you, now that Wanteds cannot rewrite Derived, I think this particular
situation can't happen.
-}
newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS ()
-- Returns superclasses, see Note [Adding superclasses]
newSCWorkFromFlavored flavor cls xis
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor
= do { given_evs <- newGivenEvVars (mk_given_loc loc)
(mkEvScSelectors (EvId evar) cls xis)
; emitWorkNC given_evs }
mkGivensWithSuperClasses :: CtLoc -> [EvId] -> TcS [Ct]
-- From a given EvId, make its Ct, plus the Ct's of its superclasses
-- See Note [The superclass story]
-- The loop-breaking here follows Note [Expanding superclasses] in TcType
mkGivensWithSuperClasses loc ev_ids = concatMapM go ev_ids
where
go ev_id = mk_superclasses emptyNameSet $
CtGiven { ctev_evar = ev_id
, ctev_pred = evVarPred ev_id
, ctev_loc = loc }
makeSuperClasses :: [Ct] -> TcS [Ct]
-- Returns strict superclasses, transitively, see Note [The superclasses story]
-- See Note [The superclass story]
-- The loop-breaking here follows Note [Expanding superclasses] in TcType
makeSuperClasses cts = concatMapM go cts
where
go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
= mk_strict_superclasses emptyNameSet ev cls tys
go ct = pprPanic "makeSuperClasses" (ppr ct)
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]
-- Return this class constraint, plus its superclasses
mk_superclasses_of rec_clss ev cls tys
| loop_found
= return [this_ct]
| otherwise
= do { sc_cts <- mk_strict_superclasses rec_clss' ev cls tys
; return (this_ct : sc_cts) }
where
cls_nm = className cls
loop_found = cls_nm `elemNameSet` rec_clss
rec_clss' | isCTupleClass cls = rec_clss -- Never contribute to recursion
| otherwise = rec_clss `extendNameSet` cls_nm
this_ct = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
, cc_pend_sc = loop_found }
mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
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 }
| isEmptyVarSet (tyCoVarsOfTypes xis)
= return () -- Wanteds with no variables yield no deriveds.
| isEmptyVarSet (tyCoVarsOfTypes tys)
= return [] -- Wanteds with no variables yield no deriveds.
-- See Note [Improvement from Ground Wanteds]
| otherwise -- Wanted/Derived case, just add those SC that can lead to improvement.
= do { let sc_rec_theta = transSuperClasses cls xis
impr_theta = filter isImprovementPred sc_rec_theta
loc = ctEvLoc flavor
; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
; emitNewDeriveds loc impr_theta }
= do { let loc = ctEvLoc ev
; sc_evs <- mapM (newDerivedNC loc) (immSuperClasses cls tys)
; concatMapM (mk_superclasses rec_clss) sc_evs }
where
size = sizeTypes xis
size = sizeTypes tys
mk_given_loc loc
| isCTupleClass cls
= loc -- For tuple predicates, just take them apart, without
......@@ -373,6 +450,8 @@ newSCWorkFromFlavored flavor cls xis
| otherwise -- Probably doesn't happen, since this function
= loc -- is only used for Givens, but does no harm
{-
************************************************************************
* *
......@@ -1876,3 +1955,4 @@ unify_derived loc role orig_ty1 orig_ty2
maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
maybeSym IsSwapped co = mkTcSymCo co
maybeSym NotSwapped co = co
......@@ -345,7 +345,7 @@ warnRedundantConstraints ctxt env info ev_vars
_ -> ev_vars
improving ev_var = any isImprovementPred $
transSuperClassesPred (idType ev_var)
transSuperClasses (idType ev_var)
{- Note [Redundant constraints in instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -406,8 +406,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
True, mkUserTypeErrorReporter)
, ("insoluble1", is_given_eq, True, mkGroupReporter mkEqErr)
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("insoluble3", rigid_nom_tv_eq, True, mkSkolReporter)
, ("insoluble4", rigid_nom_eq, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("skolem eq2", skolem_eq, True, mkSkolReporter)
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
, ("Out of scope", is_out_of_scope, True, mkHoleReporter)
, ("Holes", is_hole, False, mkHoleReporter)
......@@ -420,28 +421,41 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
, ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
rigid_nom_eq, rigid_nom_tv_eq, is_hole, is_dict,
-- rigid_nom_eq, rigid_nom_tv_eq,
is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
utterly_wrong _ _ = False
is_out_of_scope ct _ = isOutOfScopeCt ct
is_hole ct _ = isHoleCt ct
is_given_eq ct pred
| EqPred {} <- pred = arisesFromGivens ct
| otherwise = False
-- I think all given residuals are equalities
is_user_type_error ct _ = isUserTypeErrorCt ct
-- Things like (Int ~N Bool)
utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
utterly_wrong _ _ = False
-- Things like (a ~N Int)
very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
very_wrong _ _ = False
-- Things like (a ~N b) or (a ~N F Bool)
skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
skolem_eq _ _ = False
-- Skolem (i.e. non-meta) type variable on the left
rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred
-- Things like (F a ~N Int)
non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
non_tv_eq _ _ = False
rigid_nom_tv_eq _ pred
| EqPred _ ty1 _ <- pred = isRigidEqPred tc_lvl pred && isTyVarTy ty1
| otherwise = False
-- rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred
--
-- rigid_nom_tv_eq _ pred
-- | EqPred _ ty1 _ <- pred = isRigidEqPred tc_lvl pred && isTyVarTy ty1
-- | otherwise = False
is_out_of_scope ct _ = isOutOfScopeCt ct
is_hole ct _ = isHoleCt ct
is_user_type_error ct _ = isUserTypeErrorCt ct
is_equality _ (EqPred {}) = True
is_equality _ _ = False
......@@ -457,6 +471,15 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
---------------
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy tc_lvl ty
= case getTyVar_maybe ty of
Nothing -> False
Just tv -> isSkolemTyVar tv
|| (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)
-- The latter case is for touchable SigTvs
-- we postpone untouchables to a latter test (too obscure)
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
......@@ -476,15 +499,19 @@ type ReporterSpec
, Reporter) -- The reporter itself
mkSkolReporter :: Reporter
-- Suppress duplicates with the same LHS
-- Suppress duplicates with either the same LHS, or same location
mkSkolReporter ctxt cts
= mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts)
= mapM_ (reportGroup mkEqErr ctxt) (group cts)
where
cmp_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2)
_ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
group [] = []
group (ct:cts) = (ct : yeses) : group noes
where
(yeses, noes) = partition (group_with ct) cts
group_with ct1 ct2
| EQ <- cmp_loc ct1 ct2 = True
| EQ <- cmp_lhs_type ct1 ct2 = True
| otherwise = False
mkHoleReporter :: Reporter
-- Reports errors one at a time
......@@ -515,7 +542,16 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
where
cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
cmp_lhs_type :: Ct -> Ct -> Ordering
cmp_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2)
_ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
......
{-# LANGUAGE CPP #-}
module TcInteract (
solveSimpleGivens, -- Solves [EvVar],GivenLoc
solveSimpleGivens, -- Solves [Ct]
solveSimpleWanteds, -- Solves Cts
solveCallStack, -- for use in TcSimplify
......@@ -132,24 +132,18 @@ that prepareInertsForImplications will discard the insolubles, so we
must keep track of them separately.
-}
solveSimpleGivens :: CtLoc -> [EvVar] -> TcS Cts
-- Solves the givens, adding them to the inert set
-- Returns any insoluble givens, which represent inaccessible code,
-- taking those ones out of the inert set
solveSimpleGivens loc givens
solveSimpleGivens :: [Ct] -> TcS Cts
solveSimpleGivens givens
| null givens -- Shortcut for common case
= return emptyCts
| otherwise
= do { go (map mk_given_ct givens)
= do { go givens
; takeGivenInsolubles }
where
mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id
, ctev_pred = evVarPred ev_id
, ctev_loc = loc })
go givens = do { solveSimples (listToBag givens)
; new_givens <- runTcPluginsGiven
; when (notNull new_givens) (go new_givens)
}
; when (notNull new_givens) $
go new_givens }
solveSimpleWanteds :: Cts -> TcS WantedConstraints
-- NB: 'simples' may contain /derived/ equalities, floated
......
......@@ -81,7 +81,7 @@ module TcRnTypes(
toDerivedWC,
andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols,
tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,
isDroppableDerivedLoc, insolubleImplic, trulyInsoluble,
isDroppableDerivedLoc, insolubleImplic,
arisesFromGivens,
Implication(..), ImplicStatus(..), isInsolubleStatus,
......@@ -1339,7 +1339,13 @@ data Ct
= CDictCan { -- e.g. Num xi
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_class :: Class,
cc_tyargs :: [Xi] -- cc_tyargs are function-free, hence Xi
cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi
cc_pend_sc :: Bool -- True <=> (a) cc_class has superclasses
-- (b) we have not yet added those
-- superclasses as Givens
-- NB: cc_pend_sc is used for G/W/D. For W/D the reason
-- we need superclasses is to expose possible improvement
-- via fundeps
}
| CIrredEvCan { -- These stand for yet-unusable predicates
......@@ -1872,11 +1878,11 @@ trulyInsoluble :: TcLevel -> Ct -> Bool
-- The constraint is in the wc_insol set,
-- but we do not treat as truly isoluble
-- a) type-holes, arising from PartialTypeSignatures,
-- b) an out-of-scope variable
-- (except out-of-scope variables masquerading as type-holes)
-- Yuk!
trulyInsoluble tc_lvl insol
= isOutOfScopeCt insol
|| isRigidEqPred tc_lvl (classifyPredType (ctPred insol))
trulyInsoluble _tc_lvl insol
| CHoleCan {} <- insol = isOutOfScopeCt insol
| otherwise = True
instance Outputable WantedConstraints where
ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n})
......
......@@ -51,7 +51,7 @@ module TcSMonad (
emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles,
matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts,
removeInertCts,
removeInertCts, getPendingScDicts, isPendingScDict,
addInertCan, addInertEq, insertFunEq,
emitInsoluble, emitWorkNC, emitWorkCt,
......@@ -558,9 +558,7 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more
-- (b) emitDerivedShadows
, inert_dicts :: DictMap Ct
-- Dictionaries only, index is the class
-- NB: index is /not/ the whole type because FD reactions
-- need to match the class but not necessarily the whole type.
-- Dictionaries only
, inert_safehask :: DictMap Ct
-- Failed dictionary resolution due to Safe Haskell overlapping
......@@ -1568,7 +1566,7 @@ After solving the Givens we take two things out of the inert set
a) The insolubles; we return these to report inaccessible code
We return these separately. We don't want to leave them in
the inert set, lest we onfuse them with insolubles arising from
the inert set, lest we confuse them with insolubles arising from
solving wanteds
b) Any Derived CFunEqCans. Derived CTyEqCans are in the
......@@ -1633,6 +1631,35 @@ getInertGivens
$ concat (varEnvElts (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)
isPendingScDict :: Ct -> Maybe Ct
isPendingScDict ct@(CDictCan { cc_pend_sc = True })
= Just (ct { cc_pend_sc = False })