Commit 1eec1f21 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Another major constraint-solver refactoring

This patch takes further my refactoring of the constraint
solver, which I've been doing over the last couple of months
in consultation with Richard.

It fixes a number of tricky bugs that made the constraint
solver actually go into a loop, including

  Trac #12526
  Trac #12444
  Trac #12538

The main changes are these

* Flatten unification variables (fmvs/fuvs) appear on the LHS
  of a tvar/tyvar equality; thus
           fmv ~ alpha
  and not
           alpha ~ fmv

  See Note [Put flatten unification variables on the left]
  in TcUnify.  This is implemented by TcUnify.swapOverTyVars.

* Don't reduce a "loopy" CFunEqCan where the fsk appears on
  the LHS:
      F t1 .. tn ~ fsk
  where 'fsk' is free in t1..tn.
  See Note [FunEq occurs-check principle] in TcInteract

  This neatly stops some infinite loops that people reported;
  and it allows us to delete some crufty code in reduce_top_fun_eq.
  And it appears to be no loss whatsoever.

  As well as fixing loops, ContextStack2 and T5837 both terminate
  when they didn't before.

* Previously we generated "derived shadow" constraints from
  Wanteds, but we could (and sometimes did; Trac #xxxx) repeatedly
  generate a derived shadow from the same Wanted.

  A big change in this patch is to have two kinds of Wanteds:
     [WD] behaves like a pair of a Wanted and a Derived
     [W]  behaves like a Wanted only
  See CtFlavour and ShadowInfo in TcRnTypes, and the ctev_nosh
  field of a Wanted.

  This turned out to be a lot simpler.  A [WD] gets split into a
  [W] and a [D] in TcSMonad.maybeEmitShaodow.

  See TcSMonad Note [The improvement story and derived shadows]

* Rather than have a separate inert_model in the InertCans, I've
  put the derived equalities back into inert_eqs.  We weren't
  gaining anything from a separate field.

* Previously we had a mode for the constraint solver in which it
  would more aggressively solve Derived constraints; it was used
  for simplifying the context of a 'deriving' clause, or a 'default'
  delcaration, for example.

  But the complexity wasn't worth it; now I just make proper Wanted
  constraints.  See TcMType.cloneWC

* Don't generate injectivity improvement for Givens; see
  Note [No FunEq improvement for Givens] in TcInteract

* solveSimpleWanteds leaves the insolubles in-place rather than
  returning them.  Simpler.

I also did lots of work on comments, including fixing Trac #12821.
parent 0123efde
......@@ -107,6 +107,8 @@ toIfaceKind = toIfaceType
toIfaceType :: Type -> IfaceType
-- Synonyms are retained in the interface type
toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
-- | isTcTyVar tv = IfaceTyVar (toIfaceTyVar tv `appendFS` consFS '_' (mkFastString (showSDocUnsafe (ppr (getUnique tv)))))
-- | otherwise
toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceType (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) (toIfaceType t)
......
......@@ -3,7 +3,7 @@
module TcCanonical(
canonicalize,
unifyDerived,
makeSuperClasses,
makeSuperClasses, maybeSym,
StopOrContinue(..), stopWith, continueWith
) where
......
......@@ -2682,13 +2682,14 @@ relevantBindings want_filtering ctxt ct
-- et really should be filled in by now. But there's a chance
-- it hasn't, if, say, we're reporting a kind error en route to
-- checking a term. See test indexed-types/should_fail/T8129
; ty <- case mb_ty of
Just ty -> return ty
Nothing -> do { traceTc "Defaulting an ExpType in relevantBindings"
(ppr et)
; expTypeToType et }
; go2 name ty top_lvl }
-- Or we are reporting errors from the ambiguity check on
-- a local type signature
; case mb_ty of
Just ty -> go2 name ty top_lvl
Nothing -> discard_it -- No info; discard
}
where
discard_it = go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
go2 id_name id_type top_lvl
= do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
......@@ -2702,17 +2703,19 @@ relevantBindings want_filtering ctxt ct
&& id_tvs `disjointVarSet` ct_tvs)
-- We want to filter out this binding anyway
-- so discard it silently
then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
then discard_it
else if isTopLevel top_lvl && not (isNothing n_left)
-- It's a top-level binding and we have not specified
-- -fno-max-relevant-bindings, so discard it silently
then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
then discard_it
else if run_out n_left && id_tvs `subVarSet` tvs_seen
-- We've run out of n_left fuel and this binding only
-- mentions aleady-seen type variables, so discard it
then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
then go tidy_env ct_tvs n_left tvs_seen docs
True -- Record that we have now discarded something
tc_bndrs
-- Keep this binding, decrement fuel
else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
......
......@@ -1669,6 +1669,7 @@ tcUnboundId unbound res_ty
; loc <- getCtLocM HoleOrigin Nothing
; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty
, ctev_dest = EvVarDest ev
, ctev_nosh = WDeriv
, ctev_loc = loc}
, cc_hole = ExprHole unbound }
; emitInsoluble can
......
This diff is collapsed.
This diff is collapsed.
......@@ -43,7 +43,7 @@ module TcMType (
--------------------------------
-- Creating new evidence variables
newEvVar, newEvVars, newDict,
newWanted, newWanteds,
newWanted, newWanteds, cloneWanted, cloneWC,
emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
newTcEvBinds, addTcEvBind,
......@@ -170,11 +170,30 @@ newWanted orig t_or_k pty
else EvVarDest <$> newEvVar pty
return $ CtWanted { ctev_dest = d
, ctev_pred = pty
, ctev_nosh = WDeriv
, ctev_loc = loc }
newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
newWanteds orig = mapM (newWanted orig Nothing)
cloneWanted :: Ct -> TcM CtEvidence
cloneWanted ct
= newWanted (ctEvOrigin ev) Nothing (ctEvPred ev)
where
ev = ctEvidence ct
cloneWC :: WantedConstraints -> TcM WantedConstraints
cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
= do { simples' <- mapBagM clone_one simples
; implics' <- mapBagM clone_implic implics
; return (wc { wc_simple = simples', wc_impl = implics' }) }
where
clone_one ct = do { ev <- cloneWanted ct; return (mkNonCanonical ev) }
clone_implic implic@(Implic { ic_wanted = inner_wanted })
= do { inner_wanted' <- cloneWC inner_wanted
; return (implic { ic_wanted = inner_wanted' }) }
-- | Emits a new Wanted. Deals with both equalities and non-equalities.
emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
emitWanted origin pty
......@@ -188,7 +207,8 @@ emitWantedEq origin t_or_k role ty1 ty2
= do { hole <- newCoercionHole
; loc <- getCtLocM origin (Just t_or_k)
; emitSimple $ mkNonCanonical $
CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole, ctev_loc = loc }
CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
, ctev_nosh = WDeriv, ctev_loc = loc }
; return (mkHoleCo hole role ty1 ty2) }
where
pty = mkPrimEqPredRole role ty1 ty2
......@@ -201,6 +221,7 @@ emitWantedEvVar origin ty
; loc <- getCtLocM origin Nothing
; let ctev = CtWanted { ctev_dest = EvVarDest new_cv
, ctev_pred = ty
, ctev_nosh = WDeriv
, ctev_loc = loc }
; emitSimple $ mkNonCanonical ctev
; return new_cv }
......
......@@ -78,10 +78,8 @@ module TcRnTypes(
ctEvTerm, ctEvCoercion, ctEvId,
tyCoVarsOfCt, tyCoVarsOfCts,
tyCoVarsOfCtList, tyCoVarsOfCtsList,
toDerivedCt,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
toDerivedWC,
andWC, unionsWC, mkSimpleWC, mkImplicWC,
addInsols, getInsolubles, addSimples, addImplics,
tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,
......@@ -107,7 +105,7 @@ module TcRnTypes(
CtEvidence(..), TcEvDest(..),
mkGivenLoc, mkKindLoc, toKindLoc,
isWanted, isGiven, isDerived,
isWanted, isGiven, isDerived, isGivenOrWDeriv,
ctEvRole,
-- Constraint solver plugins
......@@ -115,10 +113,11 @@ module TcRnTypes(
TcPluginM, runTcPluginM, unsafeTcPluginTcM,
getEvBindsTcPluginM,
CtFlavour(..), ctEvFlavour,
CtFlavour(..), ShadowInfo(..), ctEvFlavour,
CtFlavourRole, ctEvFlavourRole, ctFlavourRole,
eqCanRewrite, eqCanRewriteFR, eqCanDischarge,
funEqCanDischarge, funEqCanDischargeFR,
eqCanRewriteFR, eqMayRewriteFR,
eqCanDischarge,
funEqCanDischarge, funEqCanDischargeF,
-- Pretty printing
pprEvVarTheta,
......@@ -174,6 +173,7 @@ import ListSetOps
import FastString
import qualified GHC.LanguageExtensions as LangExt
import Fingerprint
import Util
import Control.Monad (ap, liftM, msum)
#if __GLASGOW_HASKELL__ > 710
......@@ -1509,7 +1509,8 @@ data Ct
cc_tyvar :: TcTyVar,
cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi)
-- See invariants above
cc_eq_rel :: EqRel
cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev
}
| CFunEqCan { -- F xis ~ fsk
......@@ -1625,16 +1626,6 @@ ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant]
ctPred ct = ctEvPred (cc_ev ct)
-- | Convert a Wanted to a Derived
toDerivedCt :: Ct -> Ct
toDerivedCt ct
= case ctEvidence ct of
CtWanted { ctev_pred = pred, ctev_loc = loc }
-> ct {cc_ev = CtDerived {ctev_pred = pred, ctev_loc = loc}}
CtDerived {} -> ct
CtGiven {} -> pprPanic "to_derived" (ppr ct)
-- | Makes a new equality predicate with the same role as the given
-- evidence.
mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType
......@@ -2074,16 +2065,6 @@ andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 })
unionsWC :: [WantedConstraints] -> WantedConstraints
unionsWC = foldr andWC emptyWC
-- | Convert all Wanteds into Deriveds (ignoring insolubles)
toDerivedWC :: WantedConstraints -> WantedConstraints
toDerivedWC wc@(WC { wc_simple = simples, wc_impl = implics })
= wc { wc_simple = mapBag toDerivedCt simples
, wc_impl = mapBag to_derived_implic implics }
where
to_derived_implic implic@(Implic { ic_wanted = inner_wanted })
= implic { ic_wanted = toDerivedWC inner_wanted }
addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints
addSimples wc cts
= wc { wc_simple = wc_simple wc `unionBags` cts }
......@@ -2113,21 +2094,23 @@ isInsolubleStatus _ = False
insolubleImplic :: Implication -> Bool
insolubleImplic ic = isInsolubleStatus (ic_status ic)
insolubleWC :: TcLevel -> WantedConstraints -> Bool
insolubleWC tc_lvl (WC { wc_impl = implics, wc_insol = insols })
= anyBag (trulyInsoluble tc_lvl) insols
insolubleWC :: WantedConstraints -> Bool
insolubleWC (WC { wc_impl = implics, wc_insol = insols })
= anyBag trulyInsoluble insols
|| anyBag insolubleImplic implics
trulyInsoluble :: TcLevel -> Ct -> Bool
trulyInsoluble :: Ct -> Bool
-- Constraints in the wc_insol set which ARE NOT
-- treated as truly insoluble:
-- a) type holes, arising from PartialTypeSignatures,
-- b) "true" expression holes arising from TypedHoles
--
-- Out-of-scope variables masquerading as expression holes
-- ARE treated as truly insoluble.
-- A "expression hole" or "type hole" constraint isn't really an error
-- at all; it's a report saying "_ :: Int" here. But an out-of-scope
-- variable masquerading as expression holes IS treated as truly
-- insoluble, so that it trumps other errors during error reporting.
-- Yuk!
trulyInsoluble _tc_lvl insol
trulyInsoluble insol
| isHoleCt insol = isOutOfScopeCt insol
| otherwise = True
......@@ -2342,22 +2325,25 @@ data TcEvDest
-- See Note [Coercion holes] in TyCoRep
data CtEvidence
= CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence]
, ctev_loc :: CtLoc }
-- Truly given, not depending on subgoals
-- NB: Spontaneous unifications belong here
| CtWanted { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_dest :: TcEvDest
, ctev_loc :: CtLoc }
-- Wanted goal
| CtDerived { ctev_pred :: TcPredType
, ctev_loc :: CtLoc }
-- A goal that we don't really have to solve and can't immediately
-- rewrite anything other than a derived (there's no evidence!)
-- but if we do manage to solve it may help in solving other goals.
= CtGiven -- Truly given, not depending on subgoals
-- NB: Spontaneous unifications belong here
{ ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence]
, ctev_loc :: CtLoc }
| CtWanted -- Wanted goal
{ ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_dest :: TcEvDest
, ctev_nosh :: ShadowInfo -- See Note [Constraint flavours]
, ctev_loc :: CtLoc }
| CtDerived -- A goal that we don't really have to solve and can't
-- immediately rewrite anything other than a derived
-- (there's no evidence!) but if we do manage to solve
-- it may help in solving other goals.
{ ctev_pred :: TcPredType
, ctev_loc :: CtLoc }
ctEvPred :: CtEvidence -> TcPredType
-- The predicate of a flavor
......@@ -2399,11 +2385,12 @@ instance Outputable TcEvDest where
ppr (EvVarDest ev) = ppr ev
instance Outputable CtEvidence where
ppr fl = case fl of
CtGiven {} -> text "[G]" <+> ppr (ctev_evar fl) <+> ppr_pty
CtWanted {} -> text "[W]" <+> ppr (ctev_dest fl) <+> ppr_pty
CtDerived {} -> text "[D]" <+> text "_" <+> ppr_pty
where ppr_pty = dcolon <+> ppr (ctEvPred fl)
ppr ev = ppr (ctEvFlavour ev) <+> pp_ev <+> dcolon <+> ppr (ctEvPred ev)
where
pp_ev = case ev of
CtGiven { ctev_evar = v } -> ppr v
CtWanted {ctev_dest = d } -> ppr d
CtDerived {} -> text "_"
isWanted :: CtEvidence -> Bool
isWanted (CtWanted {}) = True
......@@ -2424,23 +2411,62 @@ isDerived _ = False
%* *
%************************************************************************
Just an enum type that tracks whether a constraint is wanted, derived,
or given, when we need to separate that info from the constraint itself.
Note [Constraint flavours]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Constraints come in four flavours:
* [G] Given: we have evidence
* [W] Wanted WOnly: we want evidence
* [D] Derived: any solution must satisfy this constraint, but
we don't need evidence for it. Examples include:
- superclasses of [W] class constraints
- equalities arising from functional dependencies
or injectivity
* [WD] Wanted WDeriv: a single constraint that represents
both [W] and [D]
We keep them paired as one both for efficiency, and because
when we have a finite map F tys -> CFunEqCan, it's inconvenient
to have two CFunEqCans in the range
The ctev_nosh field of a Wanted distinguishes between [W] and [WD]
Wanted constraints are born as [WD], but are split into [W] and its
"shadow" [D] in TcSMonad.maybeEmitShadow.
See Note [The improvement story and derived shadows] in TcSMonad
-}
data CtFlavour = Given | Wanted | Derived
data CtFlavour -- See Note [Constraint flavours]
= Given
| Wanted ShadowInfo
| Derived
deriving Eq
data ShadowInfo
= WDeriv -- [WD] This Wanted constraint has no Derived shadow,
-- so it behaves like a pair of a Wanted and a Derived
| WOnly -- [W] It has a separate derived shadow
-- See Note [Derived shadows]
deriving( Eq )
isGivenOrWDeriv :: CtFlavour -> Bool
isGivenOrWDeriv Given = True
isGivenOrWDeriv (Wanted WDeriv) = True
isGivenOrWDeriv _ = False
instance Outputable CtFlavour where
ppr Given = text "[G]"
ppr Wanted = text "[W]"
ppr Derived = text "[D]"
ppr Given = text "[G]"
ppr (Wanted WDeriv) = text "[WD]"
ppr (Wanted WOnly) = text "[W]"
ppr Derived = text "[D]"
ctEvFlavour :: CtEvidence -> CtFlavour
ctEvFlavour (CtWanted {}) = Wanted
ctEvFlavour (CtGiven {}) = Given
ctEvFlavour (CtDerived {}) = Derived
ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh
ctEvFlavour (CtGiven {}) = Given
ctEvFlavour (CtDerived {}) = Derived
-- | Whether or not one 'Ct' can rewrite another is determined by its
-- flavour and its equality relation. See also
......@@ -2456,7 +2482,7 @@ ctFlavourRole :: Ct -> CtFlavourRole
ctFlavourRole = ctEvFlavourRole . cc_ev
{- Note [eqCanRewrite]
~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~
(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form
tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of
a can-rewrite relation, see Definition [Can-rewrite relation] in
......@@ -2498,9 +2524,31 @@ I thought maybe we could never get Derived ReprEq constraints, but
we can; straight from the Wanteds during improvment. And from a Derived
ReprEq we could conceivably get a Derived NomEq improvment (by decomposing
a type constructor with Nomninal role), and hence unify.
-}
Note [funEqCanDischarge]
~~~~~~~~~~~~~~~~~~~~~~~~~
eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool
-- Can fr1 actually rewrite fr2?
-- Very important function!
-- See Note [eqCanRewrite]
-- See Note [Wanteds do not rewrite Wanteds]
-- See Note [Deriveds do rewrite Deriveds]
eqCanRewriteFR (Given, NomEq) (_, _) = True
eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True
eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True
eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True
eqCanRewriteFR _ _ = False
eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool
-- Is it /possible/ that fr1 can rewrite fr2?
-- This is used when deciding which inerts to kick out,
-- at which time a [WD] inert may be split into [W] and [D]
eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True
eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True
eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2
-----------------
{- Note [funEqCanDischarge]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have two CFunEqCans with the same LHS:
(x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2)
Can we drop x2 in favour of x1, either unifying
......@@ -2508,12 +2556,37 @@ f2 (if it's a flatten meta-var) or adding a new Given
(f1 ~ f2), if x2 is a Given?
Answer: yes if funEqCanDischarge is true.
-}
Note [eqCanDischarge]
~~~~~~~~~~~~~~~~~~~~~
Suppose we have two identicla equality constraints
funEqCanDischarge
:: CtEvidence -> CtEvidence
-> ( SwapFlag -- NotSwapped => lhs can discharge rhs
-- Swapped => rhs can discharge lhs
, Bool) -- True <=> upgrade non-discharded one
-- from [W] to [WD]
-- See Note [funEqCanDischarge]
funEqCanDischarge ev1 ev2
= ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 )
ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 )
-- CFunEqCans are all Nominal, hence asserts
funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2)
funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)
funEqCanDischargeF Given _ = (NotSwapped, False)
funEqCanDischargeF _ Given = (IsSwapped, False)
funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False)
funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True)
funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False)
funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True)
funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True)
funEqCanDischargeF Derived Derived = (NotSwapped, False)
{- Note [eqCanDischarge]
~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have two identical CTyEqCan equality constraints
(i.e. both LHS and RHS are the same)
(x1:s~t) `eqCanDischarge` (xs:s~t)
(x1:a~t) `eqCanDischarge` (xs:a~t)
Can we just drop x2 in favour of x1?
Answer: yes if eqCanDischarge is true.
......@@ -2525,48 +2598,27 @@ other Deriveds in the model whereas the Wanted cannot.
However a Wanted can certainly discharge an identical Wanted. So
eqCanDischarge does /not/ define a can-rewrite relation in the
sense of Definition [Can-rewrite relation] in TcSMonad.
-}
-----------------
eqCanRewrite :: CtEvidence -> CtEvidence -> Bool
-- Very important function!
-- See Note [eqCanRewrite]
-- See Note [Wanteds do not rewrite Wanteds]
-- See Note [Deriveds do rewrite Deriveds]
eqCanRewrite ev1 ev2 = eqCanRewriteFR (ctEvFlavourRole ev1)
(ctEvFlavourRole ev2)
We /do/ say that a [W] can discharge a [WD]. In evidence terms it
certainly can, and the /caller/ arranges that the otherwise-lost [D]
is spat out as a new Derived. -}
eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool
eqCanRewriteFR (Given, NomEq) (_, _) = True
eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True
eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True
eqCanRewriteFR _ _ = False
-----------------
funEqCanDischarge :: CtEvidence -> CtEvidence -> Bool
-- See Note [funEqCanDischarge]
funEqCanDischarge ev1 ev2 = funEqCanDischargeFR (ctEvFlavourRole ev1)
(ctEvFlavourRole ev2)
funEqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool
funEqCanDischargeFR (_, ReprEq) (_, NomEq) = False
funEqCanDischargeFR (Given, _) _ = True
funEqCanDischargeFR (Wanted, _) (Wanted, _) = True
funEqCanDischargeFR (Wanted, _) (Derived, _) = True
funEqCanDischargeFR (Derived, _) (Derived, _) = True
funEqCanDischargeFR _ _ = False
-----------------
eqCanDischarge :: CtEvidence -> CtEvidence -> Bool
-- See Note [eqCanDischarge]
eqCanDischarge ev1 ev2 = eqCanDischargeFR (ctEvFlavourRole ev1)
(ctEvFlavourRole ev2)
eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool
eqCanDischargeFR (_, ReprEq) (_, NomEq) = False
eqCanDischargeFR (Given, _) (Given,_) = True
eqCanDischargeFR (Wanted, _) (Wanted, _) = True
eqCanDischargeFR (Derived, _) (Derived, _) = True
eqCanDischargeFR _ _ = False
eqCanDischargeFR (_, ReprEq) (_, NomEq) = False
eqCanDischargeFR (f1,_) (f2, _) = eqCanDischargeF f1 f2
eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool
eqCanDischargeF Given _ = True
eqCanDischargeF (Wanted _) (Wanted _) = True
eqCanDischargeF (Wanted WDeriv) Derived = True
eqCanDischargeF Derived Derived = True
eqCanDischargeF _ _ = False
{-
************************************************************************
......
......@@ -287,16 +287,14 @@ EvVar for the coercion, fill the hole with the invented EvVar, and
then quantify over the EvVar. Not too tricky -- just some
impedence matching, really.
Note [Simplify *derived* constraints]
Note [Simplify cloned constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At this stage, we're simplifying constraints only for insolubility
and for unification. Note that all the evidence is quickly discarded.
We make this explicit by working over derived constraints, for which
there is no evidence. Using derived constraints also prevents solved
equalities from being written to coercion holes. If we don't do this,
We use a clone of the real constraint. If we don't do this,
then RHS coercion-hole constraints get filled in, only to get filled
in *again* when solving the implications emitted from tcRule. That's
terrible, so we avoid the problem by using derived constraints.
terrible, so we avoid the problem by cloning the constraints.
-}
......@@ -310,15 +308,16 @@ simplifyRule :: RuleName
simplifyRule name lhs_wanted rhs_wanted
= do { -- We allow ourselves to unify environment
-- variables: runTcS runs with topTcLevel
; tc_lvl <- getTcLevel
; lhs_clone <- cloneWC lhs_wanted
; rhs_clone <- cloneWC rhs_wanted
; insoluble <- runTcSDeriveds $
do { -- First solve the LHS and *then* solve the RHS
-- See Note [Solve order for RULES]
-- See Note [Simplify *derived* constraints]
lhs_resid <- solveWanteds $ toDerivedWC lhs_wanted
; rhs_resid <- solveWanteds $ toDerivedWC rhs_wanted
; return ( insolubleWC tc_lvl lhs_resid ||
insolubleWC tc_lvl rhs_resid ) }
-- See Note [Simplify cloned constraints]
lhs_resid <- solveWanteds lhs_clone
; rhs_resid <- solveWanteds rhs_clone
; return ( insolubleWC lhs_resid ||
insolubleWC rhs_resid ) }
; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted)
......
This diff is collapsed.
......@@ -413,8 +413,7 @@ simplifyAmbiguityCheck ty wanteds
-- inaccessible code
; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
; traceTc "reportUnsolved(ambig) {" empty
; tc_lvl <- TcM.getTcLevel
; unless (allow_ambiguous && not (insolubleWC tc_lvl final_wc))
; unless (allow_ambiguous && not (insolubleWC final_wc))
(discardResult (reportUnsolved final_wc))
; traceTc "reportUnsolved(ambig) }" empty
......@@ -431,11 +430,8 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it
-> TcM () -- Succeeds if the constraint is soluble
simplifyDefault theta
= do { traceTc "simplifyDefault" empty
; loc <- getCtLocM DefaultOrigin Nothing
; let wanted = [ CtDerived { ctev_pred = pred
, ctev_loc = loc }
| pred <- theta ]
; unsolved <- runTcSDeriveds (solveWanteds (mkSimpleWC wanted))
; wanteds <- newWanteds DefaultOrigin theta
; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))
; traceTc "reportUnsolved {" empty
; reportAllUnsolved unsolved
; traceTc "reportUnsolved }" empty
......@@ -451,7 +447,8 @@ tcCheckSatisfiability given_ids
do { traceTcS "checkSatisfiability {" (ppr given_ids)
; let given_cts = mkGivens given_loc (bagToList given_ids)
-- See Note [Superclasses and satisfiability]
; insols <- solveSimpleGivens given_cts
; solveSimpleGivens given_cts