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 ...@@ -565,6 +565,7 @@ data ExtensionFlag
| Opt_OverlappingInstances | Opt_OverlappingInstances
| Opt_UndecidableInstances | Opt_UndecidableInstances
| Opt_IncoherentInstances | Opt_IncoherentInstances
| Opt_UndecidableSuperClasses
| Opt_MonomorphismRestriction | Opt_MonomorphismRestriction
| Opt_MonoPatBinds | Opt_MonoPatBinds
| Opt_MonoLocalBinds | Opt_MonoLocalBinds
...@@ -3261,6 +3262,7 @@ xFlags = [ ...@@ -3261,6 +3262,7 @@ xFlags = [
flagSpec "TypeSynonymInstances" Opt_TypeSynonymInstances, flagSpec "TypeSynonymInstances" Opt_TypeSynonymInstances,
flagSpec "UnboxedTuples" Opt_UnboxedTuples, flagSpec "UnboxedTuples" Opt_UnboxedTuples,
flagSpec "UndecidableInstances" Opt_UndecidableInstances, flagSpec "UndecidableInstances" Opt_UndecidableInstances,
flagSpec "UndecidableSuperClasses" Opt_UndecidableSuperClasses,
flagSpec "UnicodeSyntax" Opt_UnicodeSyntax, flagSpec "UnicodeSyntax" Opt_UnicodeSyntax,
flagSpec "UnliftedFFITypes" Opt_UnliftedFFITypes, flagSpec "UnliftedFFITypes" Opt_UnliftedFFITypes,
flagSpec "ViewPatterns" Opt_ViewPatterns flagSpec "ViewPatterns" Opt_ViewPatterns
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
module TcCanonical( module TcCanonical(
canonicalize, canonicalize,
unifyDerived, unifyDerived,
makeSuperClasses, mkGivensWithSuperClasses,
StopOrContinue(..), stopWith, continueWith StopOrContinue(..), stopWith, continueWith
) where ) where
...@@ -27,6 +27,7 @@ import OccName( OccName ) ...@@ -27,6 +27,7 @@ import OccName( OccName )
import Outputable import Outputable
import DynFlags( DynFlags ) import DynFlags( DynFlags )
import VarSet import VarSet
import NameSet
import RdrName import RdrName
import Pair import Pair
...@@ -147,11 +148,11 @@ canonicalize ct@(CNonCanonical { cc_ev = ev }) ...@@ -147,11 +148,11 @@ canonicalize ct@(CNonCanonical { cc_ev = ev })
; {-# SCC "canEvVar" #-} ; {-# SCC "canEvVar" #-}
canEvNC ev } canEvNC ev }
canonicalize (CDictCan { cc_ev = ev canonicalize (CDictCan { cc_ev = ev, cc_class = cls
, cc_class = cls , cc_tyargs = xis, cc_pend_sc = pend_sc })
, cc_tyargs = xis })
= {-# SCC "canClass" #-} = {-# SCC "canClass" #-}
canClass ev cls xis -- Do not add any superclasses canClass ev cls xis pend_sc
canonicalize (CTyEqCan { cc_ev = ev canonicalize (CTyEqCan { cc_ev = ev
, cc_tyvar = tv , cc_tyvar = tv
, cc_rhs = xi , cc_rhs = xi
...@@ -191,59 +192,118 @@ canEvNC ev ...@@ -191,59 +192,118 @@ canEvNC ev
************************************************************************ ************************************************************************
-} -}
canClass, canClassNC canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
:: CtEvidence
-> Class -> [Type] -> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence -- 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 canClass :: CtEvidence -> Class -> [Type] -> Bool -> TcS (StopOrContinue Ct)
-- and adds superclasses. The plain canClass version is used -- Precondition: EvVar is class evidence
-- 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 ev cls tys canClass ev cls tys pend_sc
= -- all classes do *nominal* matching = -- all classes do *nominal* matching
ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
do { (xis, cos) <- flattenManyNom ev tys do { (xis, cos) <- flattenManyNom ev tys
; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
xi = mkClassPred cls xis xi = mkClassPred cls xis
mk_ct new_ev = CDictCan { cc_ev = new_ev 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 ; mb <- rewriteEvidence ev xi co
; traceTcS "canClass" (vcat [ ppr ev ; traceTcS "canClass" (vcat [ ppr ev
, ppr xi, ppr mb ]) , ppr xi, ppr mb ])
; return (fmap mk_ct mb) } ; return (fmap mk_ct mb) }
emitSuperclasses :: Ct -> TcS (StopOrContinue Ct) {- Note [The superclass story]
emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls }) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Add superclasses of this one here, See Note [Adding superclasses]. We need to add superclass constraints for two reasons:
-- But only if we are not simplifying the LHS of a rule.
= do { newSCWorkFromFlavored ev cls xis_new * For givens, they give us a route to to proof. E.g.
-- Arguably we should "seq" the coercions if they are derived, f :: Ord a => a -> Bool
-- as we do below for emit_kind_constraint, to allow errors in f x = x == x
-- superclasses to be executed if deferred to runtime! We get a Wanted (Eq a), which can only be solved from the superclass
; continueWith ct } of the Given (Ord a).
emitSuperclasses _ = panic "emit_superclasses of non-class!"
* For wanteds, they may give useful functional dependencies. E.g.
{- Note [Adding superclasses] class C a b | a -> b where ...
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ class C a b => D a b where ...
Since dictionaries are canonicalized only once in their lifetime, the Now a Wanted constraint (D Int beta) has (C Int beta) as a superclass
place to add their superclasses is canonicalisation. See Note [Add and that might tell us about beta, via C's fundeps. We can get this
superclasses only during canonicalisation]. Here is what we do: 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
Givens: Add all their superclasses as Givens. to generate fundep equalities.
They may be needed to prove Wanteds.
See Note [Why adding superclasses can help].
Wanteds/Derived:
Add all their superclasses as Derived. For these reasons we want to generate superclass constraints for both
The sole reason is to expose functional dependencies Givens and Wanteds. But:
in superclasses or equality superclasses.
* (Minor) they are often not needed, so generating them aggressively
Examples of how adding superclasses as Derived is useful 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 --- Example 1
class C a b | a -> b class C a b | a -> b
...@@ -280,34 +340,8 @@ Examples of how adding superclasses as Derived is useful ...@@ -280,34 +340,8 @@ Examples of how adding superclasses as Derived is useful
[D] beta ~ b [D] beta ~ b
which is what we want. which is what we want.
---------- Historical note ----------- Note [Danger of adding superclasses during solving]
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.
Here's a serious, but now out-dated example, from Trac #4497: Here's a serious, but now out-dated example, from Trac #4497:
class Num (RealOf t) => Normed t class Num (RealOf t) => Normed t
...@@ -334,27 +368,70 @@ Mind you, now that Wanteds cannot rewrite Derived, I think this particular ...@@ -334,27 +368,70 @@ Mind you, now that Wanteds cannot rewrite Derived, I think this particular
situation can't happen. situation can't happen.
-} -}
newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS () mkGivensWithSuperClasses :: CtLoc -> [EvId] -> TcS [Ct]
-- Returns superclasses, see Note [Adding superclasses] -- From a given EvId, make its Ct, plus the Ct's of its superclasses
newSCWorkFromFlavored flavor cls xis -- See Note [The superclass story]
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor -- The loop-breaking here follows Note [Expanding superclasses] in TcType
= do { given_evs <- newGivenEvVars (mk_given_loc loc) mkGivensWithSuperClasses loc ev_ids = concatMapM go ev_ids
(mkEvScSelectors (EvId evar) cls xis) where
; emitWorkNC given_evs } 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] -- See Note [Improvement from Ground Wanteds]
| otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement.
= do { let sc_rec_theta = transSuperClasses cls xis = do { let loc = ctEvLoc ev
impr_theta = filter isImprovementPred sc_rec_theta ; sc_evs <- mapM (newDerivedNC loc) (immSuperClasses cls tys)
loc = ctEvLoc flavor ; concatMapM (mk_superclasses rec_clss) sc_evs }
; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
; emitNewDeriveds loc impr_theta }
where where
size = sizeTypes xis size = sizeTypes tys
mk_given_loc loc mk_given_loc loc
| isCTupleClass cls | isCTupleClass cls
= loc -- For tuple predicates, just take them apart, without = loc -- For tuple predicates, just take them apart, without
...@@ -373,6 +450,8 @@ newSCWorkFromFlavored flavor cls xis ...@@ -373,6 +450,8 @@ newSCWorkFromFlavored flavor cls xis
| otherwise -- Probably doesn't happen, since this function | otherwise -- Probably doesn't happen, since this function
= loc -- is only used for Givens, but does no harm = loc -- is only used for Givens, but does no harm
{- {-
************************************************************************ ************************************************************************
* * * *
...@@ -1876,3 +1955,4 @@ unify_derived loc role orig_ty1 orig_ty2 ...@@ -1876,3 +1955,4 @@ unify_derived loc role orig_ty1 orig_ty2
maybeSym :: SwapFlag -> TcCoercion -> TcCoercion maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
maybeSym IsSwapped co = mkTcSymCo co maybeSym IsSwapped co = mkTcSymCo co
maybeSym NotSwapped co = co maybeSym NotSwapped co = co
...@@ -345,7 +345,7 @@ warnRedundantConstraints ctxt env info ev_vars ...@@ -345,7 +345,7 @@ warnRedundantConstraints ctxt env info ev_vars
_ -> ev_vars _ -> ev_vars
improving ev_var = any isImprovementPred $ improving ev_var = any isImprovementPred $
transSuperClassesPred (idType ev_var) transSuperClasses (idType ev_var)
{- Note [Redundant constraints in instance decls] {- Note [Redundant constraints in instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -406,8 +406,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl ...@@ -406,8 +406,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
True, mkUserTypeErrorReporter) True, mkUserTypeErrorReporter)
, ("insoluble1", is_given_eq, True, mkGroupReporter mkEqErr) , ("insoluble1", is_given_eq, True, mkGroupReporter mkEqErr)
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("insoluble3", rigid_nom_tv_eq, True, mkSkolReporter) , ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("insoluble4", rigid_nom_eq, True, mkGroupReporter mkEqErr) , ("skolem eq2", skolem_eq, True, mkSkolReporter)
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
, ("Out of scope", is_out_of_scope, True, mkHoleReporter) , ("Out of scope", is_out_of_scope, True, mkHoleReporter)
, ("Holes", is_hole, False, mkHoleReporter) , ("Holes", is_hole, False, mkHoleReporter)
...@@ -420,28 +421,41 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl ...@@ -420,28 +421,41 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
, ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] , ("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 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 is_given_eq ct pred
| EqPred {} <- pred = arisesFromGivens ct | EqPred {} <- pred = arisesFromGivens ct
| otherwise = False | otherwise = False
-- I think all given residuals are equalities -- 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 -- Things like (F a ~N Int)
rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
non_tv_eq _ _ = False
rigid_nom_tv_eq _ pred -- rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred
| EqPred _ ty1 _ <- pred = isRigidEqPred tc_lvl pred && isTyVarTy ty1 --
| otherwise = False -- 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 _ (EqPred {}) = True
is_equality _ _ = False is_equality _ _ = False
...@@ -457,6 +471,15 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl ...@@ -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 :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
Just (tc,_) | isTypeFamilyTyCon tc -> Just tc Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
...@@ -476,15 +499,19 @@ type ReporterSpec ...@@ -476,15 +499,19 @@ type ReporterSpec
, Reporter) -- The reporter itself , Reporter) -- The reporter itself
mkSkolReporter :: Reporter mkSkolReporter :: Reporter
-- Suppress duplicates with the same LHS -- Suppress duplicates with either the same LHS, or same location
mkSkolReporter ctxt cts mkSkolReporter ctxt cts
= mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts) = mapM_ (reportGroup mkEqErr ctxt) (group cts)
where where
cmp_lhs_type ct1 ct2 group [] = []
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of group (ct:cts) = (ct : yeses) : group noes
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> where
(eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2) (yeses, noes) = partition (group_with ct) cts
_ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
group_with ct1 ct2
| EQ <- cmp_loc ct1 ct2 = True
| EQ <- cmp_lhs_type ct1 ct2 = True
| otherwise = False
mkHoleReporter :: Reporter mkHoleReporter :: Reporter
-- Reports errors one at a time -- Reports errors one at a time
...@@ -515,7 +542,16 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) ...@@ -515,7 +542,16 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts) = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
where 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 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM () -> [Ct] -> TcM ()
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module TcInteract ( module TcInteract (
solveSimpleGivens, -- Solves [EvVar],GivenLoc solveSimpleGivens, -- Solves [Ct]
solveSimpleWanteds, -- Solves Cts solveSimpleWanteds, -- Solves Cts
solveCallStack, -- for use in TcSimplify solveCallStack, -- for use in TcSimplify
...@@ -132,24 +132,18 @@ that prepareInertsForImplications will discard the insolubles, so we ...@@ -132,24 +132,18 @@ that prepareInertsForImplications will discard the insolubles, so we
must keep track of them separately. must keep track of them separately.
-} -}
solveSimpleGivens :: CtLoc -> [EvVar] -> TcS Cts solveSimpleGivens :: [Ct] -> TcS Cts
-- Solves the givens, adding them to the inert set solveSimpleGivens givens
-- Returns any insoluble givens, which represent inaccessible code,
-- taking those ones out of the inert set
solveSimpleGivens loc givens
| null givens -- Shortcut for common case | null