From e1590ddc661d6a2152c7322f67b89ff89cf89406 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Sat, 6 May 2023 18:48:31 +0100
Subject: [PATCH] Add the SolverStage monad
This refactoring makes a substantial improvement in the
structure of the type-checker's constraint solver: #23070.
Specifically:
* Introduced the SolverStage monad. See GHC.Tc.Solver.Monad
Note [The SolverStage monad]
* Make each solver pipeline (equalities, dictionaries, irreds etc)
deal with updating the inert set, as a separate SolverStage. There
is sometimes special stuff to do, and it means that each full
pipeline can have type SolverStage Void, indicating that they never
return anything.
* Made GHC.Tc.Solver.Equality.zonkEqTypes into a SolverStage. Much nicer.
* Combined the remnants of GHC.Tc.Solver.Canonical and
GHC.Tc.Solver.Interact into a new module GHC.Tc.Solver.Solve.
(Interact and Canonical are removed.)
* Gave the same treatment to dictionary and irred constraints
as I have already done for equality constraints:
* New types (akin to EqCt): IrredCt and DictCt
* Ct is now just a simple sum type
data Ct
= CDictCan DictCt
| CIrredCan IrredCt
| CEqCan EqCt
| CQuantCan QCInst
| CNonCanonical CtEvidence
* inert_dicts can now have the better type DictMap DictCt, instead of
DictMap Ct; and similarly inert_irreds.
* Significantly simplified the treatment of implicit parameters.
Previously we had a number of special cases
* interactGivenIP, an entire function
* special case in maybeKickOut
* special case in findDict, when looking up dictionaries
But actually it's simpler than that. When adding a new Given, implicit
parameter constraint to the InertSet, we just need to kick out any
existing inert constraints that mention that implicit parameter.
The main work is done in GHC.Tc.Solver.InertSet.delIPDict, along with
its auxiliary GHC.Core.Predicate.mentionsIP.
See Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict.
* Add a new fast-path in GHC.Tc.Errors.Hole.tcCheckHoleFit.
See Note [Fast path for tcCheckHoleFit]. This is a big win in some cases:
test hard_hole_fits gets nearly 40% faster (at compile time).
* Add a new fast-path for solving /boxed/ equality constraints
(t1 ~ t2). See Note [Solving equality classes] in GHC.Tc.Solver.Dict.
This makes a big difference too: test T17836 compiles 40% faster.
* Implement the PermissivePlan of #23413, which concerns what happens with
insoluble Givens. Our previous treatment was wildly inconsistent as that
ticket pointed out.
A part of this, I simplified GHC.Tc.Validity.checkAmbiguity: now we simply
don't run the ambiguity check at all if -XAllowAmbiguousTypes is on.
Smaller points:
* In `GHC.Tc.Errors.misMatchOrCND` instead of having a special case for
insoluble /occurs/ checks, broaden in to all insouluble constraints.
Just generally better. See Note [Insoluble mis-match] in that module.
As noted above, compile time perf gets better. Here are the changes
over 0.5% on Fedora. (The figures are slightly larger on Windows for
some reason.)
Metrics: compile_time/bytes allocated
-------------------------------------
LargeRecord(normal) -0.9%
MultiLayerModulesTH_OneShot(normal) +0.5%
T11822(normal) -0.6%
T12227(normal) -1.8% GOOD
T12545(normal) -0.5%
T13035(normal) -0.6%
T15703(normal) -1.4% GOOD
T16875(normal) -0.5%
T17836(normal) -40.7% GOOD
T17836b(normal) -12.3% GOOD
T17977b(normal) -0.5%
T5837(normal) -1.1%
T8095(normal) -2.7% GOOD
T9020(optasm) -1.1%
hard_hole_fits(normal) -37.0% GOOD
geo. mean -1.3%
minimum -40.7%
maximum +0.5%
Metric Decrease:
T12227
T15703
T17836
T17836b
T8095
hard_hole_fits
LargeRecord
T9198
T13035
---
compiler/GHC/Builtin/Types/Prim.hs | 6 +-
compiler/GHC/Core.hs | 2 +-
compiler/GHC/Core/InstEnv.hs | 2 +-
compiler/GHC/Core/Opt/Arity.hs | 2 +-
compiler/GHC/Core/Predicate.hs | 112 +-
compiler/GHC/Core/TyCo/Compare.hs | 2 +-
compiler/GHC/Core/TyCon.hs | 6 +-
compiler/GHC/Core/Type.hs | 2 +-
compiler/GHC/Core/Unify.hs | 4 +-
compiler/GHC/HsToCore/Binds.hs | 2 +-
compiler/GHC/Tc/Deriv/Generate.hs | 2 +-
compiler/GHC/Tc/Errors.hs | 33 +-
compiler/GHC/Tc/Errors/Hole.hs | 102 +-
compiler/GHC/Tc/Errors/Types.hs | 2 +-
compiler/GHC/Tc/Gen/App.hs | 2 +-
compiler/GHC/Tc/Gen/HsType.hs | 2 +-
compiler/GHC/Tc/Gen/Pat.hs | 2 +-
compiler/GHC/Tc/Gen/Rule.hs | 2 +-
compiler/GHC/Tc/Instance/Class.hs | 59 +-
compiler/GHC/Tc/Instance/Typeable.hs | 2 +-
compiler/GHC/Tc/Solver.hs | 47 +-
compiler/GHC/Tc/Solver/Canonical.hs | 1043 -----------
compiler/GHC/Tc/Solver/Dict.hs | 1527 +++++++++++++++--
compiler/GHC/Tc/Solver/Equality.hs | 633 +++----
compiler/GHC/Tc/Solver/InertSet.hs | 450 ++++-
compiler/GHC/Tc/Solver/Interact.hs | 1274 --------------
compiler/GHC/Tc/Solver/Irred.hs | 145 ++
compiler/GHC/Tc/Solver/Monad.hs | 447 +++--
compiler/GHC/Tc/Solver/Rewrite.hs | 17 +-
compiler/GHC/Tc/Solver/Solve.hs | 720 ++++++++
compiler/GHC/Tc/Solver/Types.hs | 59 +-
compiler/GHC/Tc/TyCl/Instance.hs | 6 +-
compiler/GHC/Tc/Types/Constraint.hs | 291 ++--
compiler/GHC/Tc/Types/Evidence.hs | 6 +-
compiler/GHC/Tc/Types/Origin.hs | 4 +-
compiler/GHC/Tc/Utils/Backpack.hs | 21 +-
compiler/GHC/Tc/Utils/Monad.hs | 8 +-
compiler/GHC/Tc/Utils/TcMType.hs | 43 +-
compiler/GHC/Tc/Utils/TcType.hs | 11 +-
compiler/GHC/Tc/Utils/Unify.hs | 33 +-
compiler/GHC/Tc/Validity.hs | 27 +-
compiler/GHC/Utils/Outputable.hs | 3 +
compiler/ghc.cabal.in | 4 +-
docs/users_guide/9.8.1-notes.rst | 7 +
docs/users_guide/exts/ambiguous_types.rst | 6 +-
testsuite/tests/gadt/T3651.hs | 13 +
testsuite/tests/gadt/T3651.stderr | 39 +-
testsuite/tests/gadt/T7558.hs | 8 +
testsuite/tests/gadt/T7558.stderr | 19 +-
testsuite/tests/gadt/all.T | 4 +-
testsuite/tests/ghci/scripts/Defer02.stderr | 63 +-
.../indexed-types/should_compile/T18875.hs | 2 +-
.../indexed-types/should_fail/T13674.stderr | 17 -
testsuite/tests/linters/notes.stdout | 3 -
.../pmcheck/should_compile/T12957a.stderr | 12 -
.../tests/pmcheck/should_compile/T15450.hs | 1 +
.../pmcheck/should_compile/T15450.stderr | 4 +-
.../tests/quantified-constraints/T17267b.hs | 19 +
testsuite/tests/tcplugins/ArgsPlugin.hs | 10 +-
testsuite/tests/tcplugins/EmitWantedPlugin.hs | 8 +-
testsuite/tests/tcplugins/NullaryPlugin.hs | 8 +-
.../typecheck/should_compile/CbvOverlap.hs | 2 +-
.../typecheck/should_compile/Improvement.hs | 3 -
.../should_compile/InstanceGivenOverlap.hs | 2 +-
.../typecheck/should_compile/LocalGivenEqs.hs | 4 +-
.../tests/typecheck/should_fail/T14325.hs | 9 +
.../tests/typecheck/should_fail/T14325.stderr | 15 +-
.../typecheck/should_fail/T22924b.stderr | 2 +-
.../should_fail/TcCoercibleFail.stderr | 2 +-
.../tests/typecheck/should_run/Defer01.hs | 1 -
.../typecheck/should_run/Typeable1.stderr | 4 +-
71 files changed, 3803 insertions(+), 3651 deletions(-)
delete mode 100644 compiler/GHC/Tc/Solver/Canonical.hs
delete mode 100644 compiler/GHC/Tc/Solver/Interact.hs
create mode 100644 compiler/GHC/Tc/Solver/Irred.hs
create mode 100644 compiler/GHC/Tc/Solver/Solve.hs
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 74710077b212..5159b0dca91f 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -1037,8 +1037,8 @@ Here's what's unusual about it:
* It is "naturally coherent". This means that the solver won't hesitate to
solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the
context. (Normally, it waits to learn more, just in case the given
- influences what happens next.) See Note [Naturally coherent classes]
- in GHC.Tc.Solver.Interact.
+ influences what happens next.) See Note [Solving equality classes]
+ in GHC.Tc.Solver.Dict
* It always terminates. That is, in the UndecidableInstances checks, we
don't worry if a (~~) constraint is too big, as we know that solving
@@ -1047,7 +1047,7 @@ Here's what's unusual about it:
On the other hand, this behaves just like any class w.r.t. eager superclass
unpacking in the solver. So a lifted equality given quickly becomes an unlifted
equality given. This is good, because the solver knows all about unlifted
-equalities. There is some special-casing in GHC.Tc.Solver.Interact.matchClassInst to
+equalities. There is some special-casing in GHC.Tc.Solver.Dict.matchClassInst to
pretend that there is an instance of this class, as we can't write the instance
in Haskell.
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 96dc208e1df1..6f85f587169e 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -622,7 +622,7 @@ substitutions until the next run of the simplifier.
case (df @Int) of (co :: a ~# b) -> blah
Which is very exotic, and I think never encountered; but see
Note [Equality superclasses in quantified constraints]
- in GHC.Tc.Solver.Canonical
+ in GHC.Tc.Solver.Dict
Note [Representation polymorphism invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 749e6610f1bf..70681c84a4ee 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -598,7 +598,7 @@ of the target constraint (C ty1 .. tyn). The search works like this.
(IL0) If there are any local Givens that match (potentially unifying
any metavariables, even untouchable ones) the target constraint,
the search fails. See Note [Instance and Given overlap] in
- GHC.Tc.Solver.Interact.
+ GHC.Tc.Solver.Dict.
(IL1) Find all instances `I` that *match* the target constraint; that is, the target
constraint is a substitution instance of `I`. These instance declarations are
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index dfcf1f1ab7dc..7dc1ca02883e 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -1874,7 +1874,7 @@ The no-crap way is
\(y::Int). let j' :: Int -> Bool
j' x = e y
in b[j'/j] y
-where I have written to stress that j's type has
+where I have written b[j'/j] to stress that j's type has
changed. Note that (of course!) we have to push the application
inside the RHS of the join as well as into the body. AND if j
has an unfolding we have to push it into there too. AND j might
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index d6d5dd65200a..c1d225ecea8a 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -20,12 +20,12 @@ module GHC.Core.Predicate (
-- Class predicates
mkClassPred, isDictTy, typeDeterminesValue,
- isClassPred, isEqPredClass, isCTupleClass, isEqualityClass,
+ isClassPred, isEqualityClass, isCTupleClass,
getClassPredTys, getClassPredTys_maybe,
classMethodTy, classMethodInstTy,
-- Implicit parameters
- isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,
+ isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
isIPPred_maybe,
@@ -38,6 +38,7 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
+import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
@@ -51,8 +52,6 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.FastString
-import Control.Monad ( guard )
-
-- | A predicate in the solver. The solver tries to prove Wanted predicates
-- from Given ones.
data Pred
@@ -68,7 +67,7 @@ data Pred
-- | A quantified predicate.
--
- -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical
+ -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve
| ForAllPred [TyVar] [PredType] PredType
-- NB: There is no TuplePred case
@@ -200,7 +199,7 @@ Predicates on PredType
{-
Note [Evidence for quantified constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The superclass mechanism in GHC.Tc.Solver.Canonical.makeSuperClasses risks
+The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks
taking a quantified constraint like
(forall a. C a => a ~ b)
and generate superclass evidence
@@ -209,7 +208,7 @@ and generate superclass evidence
This is a funny thing: neither isPredTy nor isCoVarType are true
of it. So we are careful not to generate it in the first place:
see Note [Equality superclasses in quantified constraints]
-in GHC.Tc.Solver.Canonical.
+in GHC.Tc.Solver.Dict.
-}
isEvVarType :: Type -> Bool
@@ -229,7 +228,7 @@ isEqPred ty -- True of (a ~ b) and (a ~~ b)
-- ToDo: should we check saturation?
| Just tc <- tyConAppTyCon_maybe ty
, Just cls <- tyConClass_maybe tc
- = isEqPredClass cls
+ = isEqualityClass cls
| otherwise
= False
@@ -237,14 +236,6 @@ isEqPrimPred :: PredType -> Bool
isEqPrimPred ty = isCoVarType ty
-- True of (a ~# b) (a ~R# b)
-isCTupleClass :: Class -> Bool
-isCTupleClass cls = isTupleTyCon (classTyCon cls)
-
-isEqPredClass :: Class -> Bool
--- True of (~) and (~~)
-isEqPredClass cls = cls `hasKey` eqTyConKey
- || cls `hasKey` heqTyConKey
-
isEqualityClass :: Class -> Bool
-- True of (~), (~~), and Coercible
-- These all have a single primitive-equality superclass, either (~N# or ~R#)
@@ -253,6 +244,8 @@ isEqualityClass cls
|| cls `hasKey` eqTyConKey
|| cls `hasKey` coercibleTyConKey
+isCTupleClass :: Class -> Bool
+isCTupleClass cls = isTupleTyCon (classTyCon cls)
{- *********************************************************************
* *
@@ -267,39 +260,15 @@ isIPTyCon tc = tc `hasKey` ipClassKey
isIPClass :: Class -> Bool
isIPClass cls = cls `hasKey` ipClassKey
-isIPLikePred :: Type -> Bool
--- See Note [Local implicit parameters]
-isIPLikePred = is_ip_like_pred initIPRecTc
-
-
-is_ip_like_pred :: RecTcChecker -> Type -> Bool
-is_ip_like_pred rec_clss ty
- | Just (tc, tys) <- splitTyConApp_maybe ty
- , Just rec_clss' <- if isTupleTyCon tc -- Tuples never cause recursion
- then Just rec_clss
- else checkRecTc rec_clss tc
- , Just cls <- tyConClass_maybe tc
- = isIPClass cls || has_ip_super_classes rec_clss' cls tys
-
+-- | Decomposes a predicate if it is an implicit parameter. Does not look in
+-- superclasses. See also [Local implicit parameters].
+isIPPred_maybe :: Class -> [Type] -> Maybe (Type, Type)
+isIPPred_maybe cls tys
+ | isIPClass cls
+ , [t1,t2] <- tys
+ = Just (t1,t2)
| otherwise
- = False -- Includes things like (D []) where D is
- -- a Constraint-ranged family; #7785
-
-hasIPSuperClasses :: Class -> [Type] -> Bool
--- See Note [Local implicit parameters]
-hasIPSuperClasses = has_ip_super_classes initIPRecTc
-
-has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool
-has_ip_super_classes rec_clss cls tys
- = any ip_ish (classSCSelIds cls)
- where
- -- Check that the type of a superclass determines its value
- -- sc_sel_id :: forall a b. C a b -> <superclass type>
- ip_ish sc_sel_id = is_ip_like_pred rec_clss $
- classMethodInstTy sc_sel_id tys
-
-initIPRecTc :: RecTcChecker
-initIPRecTc = setRecTcMaxBound 1 initRecTc
+ = Nothing
-- --------------------- CallStack predicates ---------------------------------
@@ -333,18 +302,49 @@ isCallStackTy ty
| otherwise
= False
+-- --------------------- isIPLike and mentionsIP --------------------------
+-- See Note [Local implicit parameters]
--- | Decomposes a predicate if it is an implicit parameter. Does not look in
--- superclasses. See also [Local implicit parameters].
-isIPPred_maybe :: Type -> Maybe (FastString, Type)
-isIPPred_maybe ty =
- do (tc,[t1,t2]) <- splitTyConApp_maybe ty
- guard (isIPTyCon tc)
- x <- isStrLitTy t1
- return (x,t2)
+isIPLikePred :: Type -> Bool
+-- Is `pred`, or any of its superclasses, an implicit parameter?
+-- See Note [Local implicit parameters]
+isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred
+
+mentionsIP :: Type -> Class -> [Type] -> Bool
+-- Is (cls tys) an implicit parameter with key `str_ty`, or
+-- is any of its superclasses such at thing.
+-- See Note [Local implicit parameters]
+mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys
+
+mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool
+mentions_ip rec_clss mb_str_ty cls tys
+ | Just (str_ty', _) <- isIPPred_maybe cls tys
+ = case mb_str_ty of
+ Nothing -> True
+ Just str_ty -> str_ty `eqType` str_ty'
+ | otherwise
+ = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)
+ | sc_sel_id <- classSCSelIds cls ]
+
+mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool
+mentions_ip_pred rec_clss mb_str_ty ty
+ | Just (cls, tys) <- getClassPredTys_maybe ty
+ , let tc = classTyCon cls
+ , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
+ else checkRecTc rec_clss tc
+ = mentions_ip rec_clss' mb_str_ty cls tys
+ | otherwise
+ = False -- Includes things like (D []) where D is
+ -- a Constraint-ranged family; #7785
+
+initIPRecTc :: RecTcChecker
+initIPRecTc = setRecTcMaxBound 1 initRecTc
{- Note [Local implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
+GHC.Tc.Solver.Dict.
+
The function isIPLikePred tells if this predicate, or any of its
superclasses, is an implicit parameter.
diff --git a/compiler/GHC/Core/TyCo/Compare.hs b/compiler/GHC/Core/TyCo/Compare.hs
index 9c32675d3ea2..c0a87d34ffb3 100644
--- a/compiler/GHC/Core/TyCo/Compare.hs
+++ b/compiler/GHC/Core/TyCo/Compare.hs
@@ -324,7 +324,7 @@ The old setup was:
See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.
* Typechecker equality, as implemented by tcEqType.
- GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality.
+ GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality.
Typechecker equality implied definitional equality: if two types are equal
according to typechecker equality, then they are also equal according to
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index cfba3ebab3c5..c64ed0684ab9 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -427,7 +427,7 @@ See also:
* [Injectivity annotation] in GHC.Hs.Decls
* [Renaming injectivity annotation] in GHC.Rename.Module
* [Verifying injectivity annotation] in GHC.Core.FamInstEnv
- * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact
+ * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality
Note [Sharing nullary TyConApps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1979,7 +1979,7 @@ isTypeDataTyCon (TyCon { tyConDetails = details })
-- (where r is the role passed in):
-- If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2)
-- (where r1, r2, and r3, are the roles given by tyConRolesX tc r)
--- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical"
+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"
isInjectiveTyCon :: TyCon -> Role -> Bool
isInjectiveTyCon (TyCon { tyConDetails = details }) role
= go details role
@@ -2003,7 +2003,7 @@ isInjectiveTyCon (TyCon { tyConDetails = details }) role
-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds
-- (where r is the role passed in):
-- If (T tys ~r t), then (t's head ~r T).
--- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical"
+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"
--
-- NB: at Nominal role, isGenerativeTyCon is simple:
-- isGenerativeTyCon tc Nominal
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index a5dc5a686538..bc9f07d36499 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -1619,7 +1619,7 @@ splitTyConAppNoView_maybe ty
-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of
-- the form `TYPE rep`. This isn't usually a problem but may
-- be temporarily the cas during canonicalization:
--- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical
+-- see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality
-- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,
-- Wrinkle around FunTy
--
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index db16f7c9bbb1..dad70950a764 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -733,8 +733,8 @@ itself not purely syntactic; it accounts for CastTys;
see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep
Unlike the "impure unifiers" in the typechecker (the eager unifier in
-GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Canonical), the pure
-unifier does /not/ work up to ~.
+GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality),
+the pure unifier does /not/ work up to ~.
The algorithm implemented here is rather delicate, and we depend on it
to uphold certain properties. This is a summary of these required
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 1a025e1deca2..f58c39f3bc31 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -1406,7 +1406,7 @@ ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)
}
ds_ev_typeable ty (EvTypeableTyLit ev)
- = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact
+ = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class
do { fun <- dsLookupGlobalId tr_fun
; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol
; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 9a76c82b8f0b..d667dafdb9ae 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1810,7 +1810,7 @@ prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
*must* generate a term-level evidence binding in order to instantiate the
quantified constraint! In response, GHC currently chooses not to use such
a quantified constraint.
-See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact.
+See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Equality.
But this isn't the death knell for combining QuantifiedConstraints with GND.
On the contrary, if we generate GND bindings in a slightly different way, then
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 66f0cf118a9c..cc95deef01be 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -465,8 +465,9 @@ mkErrorItem ct
-> do { rewriters' <- zonkRewriterSet rewriters
; return (not (isEmptyRewriterSet rewriters'), Just dest) }
- ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason
- _ -> Nothing
+ ; let m_reason = case ct of
+ CIrredCan (IrredCt { ir_reason = reason }) -> Just reason
+ _ -> Nothing
; return $ Just $ EI { ei_pred = ctPred ct
, ei_evdest = m_evdest
@@ -605,7 +606,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- where alpha is untouchable; and representational equalities
-- Prefer homogeneous equalities over hetero, because the
-- former might be holding up the latter.
- -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
+ -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality
, ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", is_equality, True, mkGroupReporter mkEqErr)
]
@@ -1758,7 +1759,7 @@ reportEqErr ctxt item ty1 ty2
, mismatchAmbiguityInfo = eqInfos
, mismatchCoercibleInfo = mb_coercible_info }
where
- mismatch = misMatchOrCND False ctxt item ty1 ty2
+ mismatch = misMatchOrCND ctxt item ty1 ty2
eqInfos = eqInfoMsgs ty1 ty2
coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg)
@@ -1814,7 +1815,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
= return (mkBlockedEqErr item, [])
| isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have
- -- swapped in Solver.Canonical.canEqTyVarHomo
+ -- swapped in Solver.Equality.canEqTyVarHomo
|| isTyVarTyVar tv1 && not (isTyVarTy ty2)
|| errorItemEqRel item == ReprEq
-- The cases below don't really apply to ReprEq (except occurs check)
@@ -1906,7 +1907,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
where
- headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
+ headline_msg = misMatchOrCND ctxt item ty1 ty2
mismatch_msg = mkMismatchMsg item ty1 ty2
add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2
@@ -1935,8 +1936,6 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
Just (NonCanonicalReason result) -> result
_ -> cteOK
- insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs
-
eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo]
-- Report (a) ambiguity if either side is a type function application
-- e.g. F a0 ~ Int
@@ -1970,11 +1969,11 @@ eqInfoMsgs ty1 ty2
| otherwise
= Nothing
-misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem
+misMatchOrCND :: SolverReportErrCtxt -> ErrorItem
-> TcType -> TcType -> MismatchMsg
-- If oriented then ty1 is actual, ty2 is expected
-misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
- | insoluble_occurs_check -- See Note [Insoluble occurs check]
+misMatchOrCND ctxt item ty1 ty2
+ | insoluble_item -- See Note [Insoluble mis-match]
|| (isRigidTy ty1 && isRigidTy ty2)
|| (ei_flavour item == Given)
|| null givens
@@ -1986,6 +1985,10 @@ misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
= CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
where
+ insoluble_item = case ei_m_reason item of
+ Nothing -> False
+ Just r -> isInsolubleReason r
+
level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel
givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]
-- Keep only UserGivens that have some equalities.
@@ -2143,8 +2146,8 @@ shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act
shouldPprWithExplicitKinds ty1 ty2 _ct
= tcEqTypeVis ty1 ty2
-{- Note [Insoluble occurs check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Insoluble mis-match]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble
so we don't use it for rewriting. The Wanted is also insoluble, and
we don't solve it from the Given. It's very confusing to say
@@ -2153,7 +2156,9 @@ we don't solve it from the Given. It's very confusing to say
And indeed even thinking about the Givens is silly; [W] a ~ [a] is
just as insoluble as Int ~ Bool.
-Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)
+Exactly the same is true if we have [G] Int ~ Bool, [W] Int ~ Bool.
+
+Conclusion: if there's an insoluble constraint (isInsolubleReason),
then report it directly, not in the "cannot deduce X from Y" form.
This is done in misMatchOrCND (via the insoluble_occurs_check arg)
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index 76929e8c1106..7a582b1b3b41 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ExistentialQuantification #-}
module GHC.Tc.Errors.Hole
@@ -40,7 +41,10 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.TcType
import GHC.Core.Type
+import GHC.Core.TyCon( TyCon, isGenerativeTyCon )
+import GHC.Core.TyCo.Rep( Type(..) )
import GHC.Core.DataCon
+import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole )
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Builtin.Names ( gHC_ERR )
@@ -981,28 +985,33 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $
tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty
; traceTc "Checking hole fit {" empty
; traceTc "wanteds are: " $ ppr wanted
- ; if isEmptyWC wanted && isEmptyBag th_relevant_cts
- then do { traceTc "}" empty
- ; return (True, wrap) }
- else do { fresh_binds <- newTcEvBinds
- -- The relevant constraints may contain HoleDests, so we must
- -- take care to clone them as well (to avoid #15370).
- ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts
- -- We wrap the WC in the nested implications, for details, see
- -- Note [Checking hole fits]
- ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics
- final_wc = wrapInImpls $ addSimples wanted $
- mapBag mkNonCanonical cloned_relevants
- -- We add the cloned relevants to the wanteds generated
- -- by the call to tcSubType_NC, for details, see
- -- Note [Relevant constraints]. There's no need to clone
- -- the wanteds, because they are freshly generated by the
- -- call to`tcSubtype_NC`.
- ; traceTc "final_wc is: " $ ppr final_wc
- -- See Note [Speeding up valid hole-fits]
- ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc
- ; traceTc "}" empty
- ; return (any isSolvedWC rem, wrap) } }
+ ; if | isEmptyWC wanted, isEmptyBag th_relevant_cts
+ -> do { traceTc "}" empty
+ ; return (True, wrap) }
+
+ | checkInsoluble wanted -- See Note [Fast path for tcCheckHoleFit]
+ -> return (False, wrap)
+
+ | otherwise
+ -> do { fresh_binds <- newTcEvBinds
+ -- The relevant constraints may contain HoleDests, so we must
+ -- take care to clone them as well (to avoid #15370).
+ ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts
+ -- We wrap the WC in the nested implications, for details, see
+ -- Note [Checking hole fits]
+ ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics
+ final_wc = wrapInImpls $ addSimples wanted $
+ mapBag mkNonCanonical cloned_relevants
+ -- We add the cloned relevants to the wanteds generated
+ -- by the call to tcSubType_NC, for details, see
+ -- Note [Relevant constraints]. There's no need to clone
+ -- the wanteds, because they are freshly generated by the
+ -- call to`tcSubtype_NC`.
+ ; traceTc "final_wc is: " $ ppr final_wc
+ -- See Note [Speeding up valid hole-fits]
+ ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc
+ ; traceTc "}" empty
+ ; return (any isSolvedWC rem, wrap) } }
where
orig = ExprHoleOrigin (hole_occ <$> th_hole)
@@ -1012,3 +1021,52 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $
-> WantedConstraints -- The new constraints.
setWCAndBinds binds imp wc
= mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }
+
+{- Note [Fast path for tcCheckHoleFit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In `tcCheckHoleFit` we compare (with `tcSubTypeSigma`) the type of the hole
+with the type of zillions of in-scope functions, to see which would "fit".
+Most of these checks fail! They generate obviously-insoluble constraints.
+For these very-common cases we don't want to crank up the full constraint
+solver. It's much more efficient to do a quick-and-dirty check for insolubility.
+
+Now, `tcSubTypeSigma` uses the on-the-fly unifier in GHC.Tc.Utils.Unify,
+it has already done the dirt-simple unification. So our quick-and-dirty
+check can simply look for constraints like (Int ~ Bool). We don't need
+to worry about (Maybe Int ~ Maybe Bool).
+
+The quick-and-dirty check is in `checkInsoluble`. It can make a big
+difference: For test hard_hole_fits, compile-time allocation goes down by 37%!
+-}
+
+
+checkInsoluble :: WantedConstraints -> Bool
+-- See Note [Fast path for tcCheckHoleFit]
+checkInsoluble (WC { wc_simple = simples })
+ = any is_insol simples
+ where
+ is_insol ct = case classifyPredType (ctPred ct) of
+ EqPred r t1 t2 -> definitelyNotEqual (eqRelRole r) t1 t2
+ _ -> False
+
+definitelyNotEqual :: Role -> TcType -> TcType -> Bool
+-- See Note [Fast path for tcCheckHoleFit]
+-- Specifically, does not need to recurse under type constructors
+definitelyNotEqual r t1 t2
+ = go t1 t2
+ where
+ go t1 t2
+ | Just t1' <- coreView t1 = go t1' t2
+ | Just t2' <- coreView t2 = go t1 t2'
+
+ go (TyConApp tc _) t2 | isGenerativeTyCon tc r = go_tc tc t2
+ go t1 (TyConApp tc _) | isGenerativeTyCon tc r = go_tc tc t1
+ go (FunTy {ft_af = af1}) (FunTy {ft_af = af2}) = af1 /= af2
+ go _ _ = False
+
+ go_tc :: TyCon -> TcType -> Bool
+ -- The TyCon is generative, and is not a saturated FunTy
+ go_tc tc1 (TyConApp tc2 _) | isGenerativeTyCon tc2 r = tc1 /= tc2
+ go_tc _ (FunTy {}) = True
+ go_tc _ (ForAllTy {}) = True
+ go_tc _ _ = False
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 41fa0515ee6a..00876503335b 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -5060,7 +5060,7 @@ data TcSolverReportMsg
-- Test cases: none.
| BlockedEquality ErrorItem
-- These are for the "blocked" equalities, as described in
- -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical,
+ -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality,
-- wrinkle (EIK2). There should always be another unsolved wanted around,
-- which will ordinarily suppress this message. But this can still be printed out
-- with -fdefer-type-errors (sigh), so we must produce a message.
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 818ec4e99198..266c651fb58b 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -1082,7 +1082,7 @@ That is the entire point of qlUnify! Wrinkles:
calling unifyKind, producing a coercion perhaps emitting some deferred
equality constraints. That is /different/ from the approach we use in
the main constraint solver for heterogeneous equalities; see Note
- [Equalities with incompatible kinds] in Solver.Canonical
+ [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality
Why different? Because:
- We can't use qlUnify to solve the kind constraint because qlUnify
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index dd1b0c0eca3f..6f56a79a00b4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1818,7 +1818,7 @@ FunTy will be built without being able to purely extract the RuntimeReps.
Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,
we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*
split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]
-in GHC.Tc.Solver.Canonical.
+in GHC.Tc.Solver.Equality.
Note [mkAppTyM]
~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 28b9891b9188..3c5354288af0 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1113,7 +1113,7 @@ to see `Annotated` in the call stack.
This is achieve easily, but a bit trickily. When we instantiate
Annotated's "required" constraints, in tcPatSynPat, give them a
CtOrigin of (OccurrenceOf "Annotated"). That way the special magic
-in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack
+in GHC.Tc.Solver.Dict.solveCallStack which deals with CallStack
constraints will kick in: that logic only fires on constraints
whose Origin is (OccurrenceOf f).
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 397acd214c82..0215eb689660 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -474,7 +474,7 @@ getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
-- and attempt to solve them from the quantified constraints. That
-- nearly works, but fails for a constraint like (d :: Eq Int).
-- We /do/ want to quantify over it, but the short-cut solver
--- (see GHC.Tc.Solver.Interact Note [Shortcut solving]) ignores the quantified
+-- (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified
-- and instead solves from the top level.
--
-- So we must partition the WantedConstraints ourselves
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 43fc9dbdb9a2..0e6ad85273b0 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -2,7 +2,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Instance.Class (
- matchGlobalInst,
+ matchGlobalInst, matchEqualityInst,
ClsInstResult(..),
safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated,
@@ -120,6 +120,9 @@ matchGlobalInst :: DynFlags
-> Bool -- True <=> caller is the short-cut solver
-- See Note [Shortcut solving: overlap]
-> Class -> [Type] -> TcM ClsInstResult
+-- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass
+-- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict,
+-- which calls solveEqualityDict for equality classes.)
matchGlobalInst dflags short_cut clas tys
| cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys
| cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys
@@ -127,9 +130,6 @@ matchGlobalInst dflags short_cut clas tys
| isCTupleClass clas = matchCTuple clas tys
| cls_name == typeableClassName = matchTypeable clas tys
| cls_name == withDictClassName = matchWithDict tys
- | clas `hasKey` heqTyConKey = matchHeteroEquality tys
- | clas `hasKey` eqTyConKey = matchHomoEquality tys
- | clas `hasKey` coercibleTyConKey = matchCoercible tys
| cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys
| cls_name == unsatisfiableClassName = return NoInstance -- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors
| otherwise = matchInstEnv dflags short_cut clas tys
@@ -267,9 +267,10 @@ Conceptually, this class has infinitely many instances:
instance KnownNat 2 where natSing = SNat 2
...
-In practice, we solve `KnownNat` predicates in the type-checker
-(see GHC.Tc.Solver.Interact) because we can't have infinitely many instances.
-The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
+In practice, we solve `KnownNat` predicates in the type-checker (see
+`matchKnownNat` in this module) 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 method---like `KnownNat`---is
@@ -646,7 +647,7 @@ doFunTy clas ty mult arg_ty ret_ty
preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]
mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $
EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)
- mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy"
+ mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy"
-- | Representation for type constructor applied to some kinds.
@@ -797,33 +798,25 @@ if you'd written
***********************************************************************-}
-- See also Note [The equality types story] in GHC.Builtin.Types.Prim
-matchHeteroEquality :: [Type] -> TcM ClsInstResult
--- Solves (t1 ~~ t2)
-matchHeteroEquality args
- = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
- , cir_mk_ev = evDataConApp heqDataCon args
- , cir_coherence = IsCoherent
- , cir_what = BuiltinEqInstance })
+matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type)
+-- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass
+-- See Note [Solving equality classes] in GHC.Tc.Solver.Dict
+matchEqualityInst cls args
+ | cls `hasKey` eqTyConKey -- Solves (t1 ~ t2)
+ , [_,t1,t2] <- args
+ = (eqDataCon, Nominal, t1, t2)
-matchHomoEquality :: [Type] -> TcM ClsInstResult
--- Solves (t1 ~ t2)
-matchHomoEquality args@[k,t1,t2]
- = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
- , cir_mk_ev = evDataConApp eqDataCon args
- , cir_coherence = IsCoherent
- , cir_what = BuiltinEqInstance })
-matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
+ | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2)
+ , [_,_,t1,t2] <- args
+ = (heqDataCon, Nominal, t1, t2)
+
+ | cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2)
+ , [_, t1, t2] <- args
+ = (coercibleDataCon, Representational, t1, t2)
+
+ | otherwise -- Does not satisfy the precondition
+ = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args))
--- See also Note [The equality types story] in GHC.Builtin.Types.Prim
-matchCoercible :: [Type] -> TcM ClsInstResult
-matchCoercible args@[k, t1, t2]
- = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
- , cir_mk_ev = evDataConApp coercibleDataCon args
- , cir_coherence = IsCoherent
- , cir_what = BuiltinEqInstance })
- where
- args' = [k, k, t1, t2]
-matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
{- ********************************************************************
* *
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
index 74e3cd84b865..943dd1207d0c 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ b/compiler/GHC/Tc/Instance/Typeable.hs
@@ -94,7 +94,7 @@ The overall plan is this:
interface file to find its type, value, etc
4. Solve Typeable constraints. This is done by a custom Typeable solver,
- currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T).
+ currently in GHC.Tc.Instance.Class, that use M.$tcT so solve (Typeable T).
There are many wrinkles:
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 9c371af46380..b8a0a38edf2d 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -46,10 +46,10 @@ import GHC.Builtin.Names
import GHC.Tc.Errors
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
-import GHC.Tc.Solver.Interact
-import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack )
-import GHC.Tc.Solver.Rewrite ( rewriteType )
-import GHC.Tc.Utils.Unify ( buildTvImplication )
+import GHC.Tc.Solver.Solve ( solveSimpleGivens, solveSimpleWanteds )
+import GHC.Tc.Solver.Dict ( makeSuperClasses, solveCallStack )
+import GHC.Tc.Solver.Rewrite ( rewriteType )
+import GHC.Tc.Utils.Unify ( buildTvImplication )
import GHC.Tc.Utils.TcMType as TcM
import GHC.Tc.Utils.Monad as TcM
import GHC.Tc.Solver.InertSet
@@ -153,7 +153,7 @@ simplifyTop wanteds
; binds2 <- reportUnsolved final_wc
; traceTc "reportUnsolved (unsafe overlapping) {" empty
- ; unless (isEmptyCts unsafe_ol) $ do {
+ ; unless (isEmptyBag unsafe_ol) $ do {
-- grab current error messages and clear, warnAllUnsolved will
-- update error messages which we'll grab and then restore saved
-- messages.
@@ -161,7 +161,7 @@ simplifyTop wanteds
; saved_msg <- TcM.readTcRef errs_var
; TcM.writeTcRef errs_var emptyMessages
- ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }
+ ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol }
; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var
; TcM.writeTcRef errs_var saved_msg
@@ -277,8 +277,8 @@ floatKindEqualities wc = float_wc emptyVarSet wc
= Nothing
where
is_floatable ct
- | insolubleEqCt ct = False
- | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs
+ | insolubleCt ct = False
+ | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs
float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)
float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs
@@ -870,12 +870,12 @@ How is this implemented? It's complicated! So we'll step through it all:
list of instances that are unsafe to overlap. When the method call is safe,
the list is null.
- 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution
+ 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution
/ dictionary generation. The return type is `ClsInstResult`, which either
says no instance matched, or one found, and if it was a safe or unsafe
overlap.
- 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and
+ 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and
tries to resolve it by calling (in part) `matchClassInst`. The resolving
mechanism has a work list (of constraints) that it process one at a time. If
the constraint can't be resolved, it's added to an inert set. When compiling
@@ -998,25 +998,18 @@ last example above.
------------------
simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
simplifyAmbiguityCheck ty wanteds
- = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)
+ = do { traceTc "simplifyAmbiguityCheck {" $
+ text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds
+
; (final_wc, _) <- runTcS $ useUnsatisfiableGivens =<< solveWanteds wanteds
-- NB: no defaulting! See Note [No defaulting in the ambiguity check]
-- Note: we do still use Unsatisfiable Givens to solve Wanteds,
-- see Wrinkle [Ambiguity] under point (C) of
-- Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.
- ; traceTc "End simplifyAmbiguityCheck }" empty
-
- -- Normally report all errors; but with -XAllowAmbiguousTypes
- -- report only insoluble ones, since they represent genuinely
- -- inaccessible code
- ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
- ; traceTc "reportUnsolved(ambig) {" empty
- ; unless (allow_ambiguous && not (insolubleWC final_wc))
- (discardResult (reportUnsolved final_wc))
- ; traceTc "reportUnsolved(ambig) }" empty
+ ; discardResult (reportUnsolved final_wc)
- ; return () }
+ ; traceTc "End simplifyAmbiguityCheck }" empty }
------------------
simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
@@ -2706,7 +2699,7 @@ and suppose during type inference we obtain an implication constraint:
To solve this implication constraint, we first expand one layer of the superclass
of Given constraints, but not for Wanted constraints.
(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help]
-in GHC.Tc.Solver.Canonical.) We thus get:
+in GHC.Tc.Solver.Dict.) We thus get:
[G] g1 :: C a
[G] g2 :: C [a] -- new superclass layer from g1
@@ -2795,7 +2788,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl
-- The insoluble stuff might be in one sub-implication
-- and other unsolved goals in another; and we want to
-- solve the latter as much as possible
- = do { inerts <- getTcSInerts
+ = do { inerts <- getInertSet
; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
-- commented out; see `where` clause below
@@ -3232,7 +3225,7 @@ others).
* When two Givens are the same, we drop the evidence for the one
that requires more superclass selectors. This is done
- according to Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
+ according to Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet.
* The ic_need fields of an Implic records in-scope (given) evidence
variables bound by the context, that were needed to solve this
@@ -3274,7 +3267,7 @@ others).
All three will discover that they have two [G] Eq a constraints:
one as given and one extracted from the Ord a constraint. They will
both discard the latter, as noted above and in
- Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
+ Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet.
The body of f uses the [G] Eq a, but not the [G] Ord a. It will
report a redundant Ord a using the logic for case (a).
@@ -3396,7 +3389,7 @@ approximateWC float_past_equalities wc
is_floatable encl_eqs skol_tvs ct
| isGivenCt ct = False
- | insolubleEqCt ct = False
+ | insolubleCt ct = False
| tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False
| otherwise
= case classifyPredType (ctPred ct) of
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
deleted file mode 100644
index b775e12d1a60..000000000000
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ /dev/null
@@ -1,1043 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RecursiveDo #-}
-
-module GHC.Tc.Solver.Canonical(
- canonicalize,
- makeSuperClasses,
- StopOrContinue(..), stopWith, continueWith, andWhenContinue,
- solveCallStack -- For GHC.Tc.Solver
- ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Solver.Rewrite
-import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.Equality( solveNonCanonicalEquality, solveCanonicalEquality )
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.EvTerm
-
-import GHC.Core.Type
-import GHC.Core.Predicate
-import GHC.Core.Class
-import GHC.Core.Multiplicity
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.Core.InstEnv ( Coherence(..) )
-import GHC.Core
-
-import GHC.Hs.Type( HsIPName(..) )
-
-import GHC.Types.Id( mkTemplateLocals )
-import GHC.Types.Var
-import GHC.Types.Var.Env( mkInScopeSet )
-import GHC.Types.Var.Set( delVarSetList )
-import GHC.Types.Name.Set
-import GHC.Types.Unique ( hasKey )
-
-import GHC.Builtin.Names ( coercibleTyConKey )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-
-import GHC.Driver.Session ( givensFuel, wantedsFuel, qcsFuel )
-
-import GHC.Data.Bag
-
-import Data.Maybe ( isJust )
-import qualified Data.Semigroup as S
-import GHC.Tc.Utils.Monad (getLclEnvLoc)
-
-{-
-************************************************************************
-* *
-* 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 user-written code come into being as
-CNonCanonicals. 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 rewritten and then decomposed into one of several forms
-(see type Ct in GHC.Tc.Types).
-
-When an already-canonicalized 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.
-
--}
-
--- Top-level canonicalization
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-canonicalize :: Ct -> TcS (StopOrContinue Ct)
-canonicalize (CNonCanonical { cc_ev = ev })
- = {-# SCC "canNC" #-}
- canNC ev
-
-canonicalize (CEqCan can_eq_ct) = solveCanonicalEquality can_eq_ct
-
-canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
- = canForAll ev pend_sc
-
-canonicalize (CIrredCan { cc_ev = ev })
- = canNC ev
- -- Instead of rewriting the evidence before classifying, it's possible we
- -- can make progress without the rewrite. Try this first.
- -- For insolubles (all of which are equalities), do /not/ rewrite the arguments
- -- In #14350 doing so led entire-unnecessary 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
-
-canonicalize (CDictCan { cc_ev = ev, cc_class = cls
- , cc_tyargs = xis, cc_pend_sc = pend_sc })
- = {-# SCC "canClass" #-}
- canClass ev cls xis pend_sc
-
-canNC :: CtEvidence -> TcS (StopOrContinue Ct)
-canNC ev =
- case classifyPredType pred 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)
- solveNonCanonicalEquality ev eq_rel ty1 ty2
- IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred)
- canIrred ev
- ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
-
- where
- pred = ctEvPred ev
-
-{-
-************************************************************************
-* *
-* Class Canonicalization
-* *
-************************************************************************
--}
-
-canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
--- "NC" means "non-canonical"; 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 { dflags <- getDynFlags
- ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys
- -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
- ; emitWork (listToBag sc_cts)
- ; canClass ev cls tys doNotExpand }
- -- doNotExpand: We have already expanded superclasses for /this/ dict
- -- so set the fuel to doNotExpand to avoid repeating expansion
-
- | CtWanted { ctev_rewriters = rewriters } <- ev
- , Just ip_name <- isCallStackPred cls tys
- , isPushCallStackOrigin orig
- -- If we're given a CallStack constraint that arose from a function
- -- call, we need to push the current call-site onto the stack instead
- -- of solving it directly from a given.
- -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
- -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types
- = 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]
- -- in GHC.Tc.Types.Evidence
-
- ; new_ev <- newWantedEvVarNC new_loc rewriters pred
-
- -- Then we solve the wanted by pushing the call-site
- -- onto the newly emitted CallStack
- ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
- (ctLocSpan loc) (ctEvExpr new_ev)
- ; solveCallStack ev ev_cs
-
- ; canClass new_ev cls tys doNotExpand
- -- doNotExpand: No superclasses for class CallStack
- -- See invariants in CDictCan.cc_pend_sc
- }
-
- | otherwise
- = do { dflags <- getDynFlags
- ; let fuel | classHasSCs cls = wantedsFuel dflags
- | otherwise = doNotExpand
- -- See Invariants in `CCDictCan.cc_pend_sc`
- ; canClass ev cls tys fuel
- }
-
- where
- loc = ctEvLoc ev
- orig = ctLocOrigin loc
- pred = ctEvPred ev
-
-solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
--- Also called from GHC.Tc.Solver 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))
- setEvBindIfWanted ev IsCoherent ev_tm
-
-canClass :: CtEvidence
- -> Class -> [Type]
- -> ExpansionFuel -- n > 0 <=> un-explored superclasses
- -> TcS (StopOrContinue Ct)
--- Precondition: EvVar is class evidence
-
-canClass ev cls tys pend_sc
- = -- all classes do *nominal* matching
- assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
- do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys
- ; let redn = mkClassPredRedn cls redns
- ; rewriteEvidence rewriters ev redn $ \new_ev ->
- do { traceTcS "canClass" (vcat [ ppr new_ev, ppr (reductionReducedType redn) ])
- ; continueWith (CDictCan { cc_ev = new_ev
- , cc_tyargs = xis
- , cc_class = cls
- , cc_pend_sc = pend_sc }) }}
- 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], 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 [W] (C Int beta) constraint. We won't use the evidence,
- but it may lead to unification.
-
-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 (#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 non-canonical 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 GHC.Tc.Utils.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 superclasses for new /given/
- /non-canonical/ constraints (canClassNC does this). As #12175
- showed, a type-family 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 GHC.Tc.Types.Constraint)
- try harder: take both the Givens and Wanteds, and expand
- superclasses again. See the calls to expandSuperClasses in
- GHC.Tc.Solver.simpl_loop and solveWanteds.
-
- This may succeed in generating (a finite number of) extra Givens,
- and extra Wanteds. Both may help the proof.
-
-3a An important wrinkle: only expand Givens from the current level.
- Two reasons:
- - We only want to expand it once, and that is best done at
- the level it is bound, rather than repeatedly at the leaves
- of the implication tree
- - We may be inside a type where we can't create term-level
- evidence anyway, so we can't superclass-expand, say,
- (a ~ b) to get (a ~# b). This happened in #15290.
-
-4. Go round to (2) again. This loop (2,3,4) is implemented
- in GHC.Tc.Solver.simpl_loop.
-
-The cc_pend_sc field 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 > 0
-(i.e. isPendingScDict holds).
-See Note [Expanding Recursive Superclasses and ExpansionFuel]
-
-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 -XNoUndecidableSuperClasses
- 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 self-same
-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 cc_pend_sc has pending
-expansion fuel.)
-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
-GHC.Tc.Solver.Interact. 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 non-confluent proofs, but to stop our users
-complaining we expand one layer in advance.
-
-Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
-
-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.
-
-This same scenario happens with quantified constraints, whose superclasses
-are also eagerly expanded. Test case: typecheck/should_compile/T16502b
-These are handled in canForAllNC, analogously to 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 [W] beta~b will let us solve it.
-
- -- Example 2 (similar but using a type-equality 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
- [W] F a ~ beta
- Now we get [W] 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 hence 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 superclass
- [W] L a beta. Now using fundeps, combine with [G] L a b to get
- [W] beta ~ b
- which is what we want.
-
-Note [Danger of adding superclasses during solving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here's a serious, but now out-dated example, from #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
- [W] RealOf e ~ fuv
- [W] 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.
-
-Note [Nested quantified constraint superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (typecheck/should_compile/T17202)
-
- class C1 a
- class (forall c. C1 c) => C2 a
- class (forall b. (b ~ F a) => C2 a) => C3 a
-
-Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass
-to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a
-superclass, as well. But we now must be careful: we cannot just add
-(forall c. C1 c) as a Given, because we need to remember g2's context.
-That new constraint is Given only when forall b. (b ~ F a) is true.
-
-It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c),
-but that's problematic, because it's nested, and ForAllPred is not capable
-of representing a nested quantified constraint. (We could change ForAllPred
-to allow this, but the solution in this Note is much more local and simpler.)
-
-So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c).
-
-More generally, if we are expanding the superclasses of
- g0 :: forall tvs. theta => cls tys
-and find a superclass constraint
- forall sc_tvs. sc_theta => sc_inner_pred
-we must have a selector
- sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred
-and thus build
- g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
- g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.
- sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids
-
-Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the
-last bound variables and the last arguments. This avoids the need to produce
-the sc_theta_ids at all. So our final construction is
-
- g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.
- sel_id tys (g0 tvs theta_ids) sc_tvs
-
- -}
-
-makeSuperClasses :: [Ct] -> TcS [Ct]
--- Returns strict superclasses, transitively, see Note [The superclass story]
--- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.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 constraint's superclass will consume a unit of fuel
--- Preconditions on `cts`: 1. They are either `CDictCan` or `CQuantCan`
--- 2. Their fuel (stored in cc_pend_sc or qci_pend_sc) is > 0
-makeSuperClasses cts = concatMapM go cts
- where
- go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys, cc_pend_sc = fuel })
- = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
- mkStrictSuperClasses fuel ev [] [] cls tys
- go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
- = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
- -- class pred heads
- assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
- mkStrictSuperClasses fuel ev tvs theta cls tys
- where
- (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
- go ct = pprPanic "makeSuperClasses" (ppr ct)
-
-mkStrictSuperClasses
- :: ExpansionFuel -> CtEvidence
- -> [TyVar] -> ThetaType -- These two args are non-empty only when taking
- -- superclasses of a /quantified/ constraint
- -> Class -> [Type] -> TcS [Ct]
--- Return constraints for the strict superclasses of
--- ev :: forall as. theta => cls tys
--- Precondition: fuel > 0
--- Postcondition: fuel for recursive superclass ct is one unit less than cls fuel
-mkStrictSuperClasses fuel ev tvs theta cls tys
- = mk_strict_superclasses (consumeFuel fuel) (unitNameSet (className cls))
- ev tvs theta cls tys
-
-mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
- -> [TyVar] -> ThetaType
- -> 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
--- The caller of this function is supposed to perform fuel book keeping
--- Precondition: fuel >= 0
-mk_strict_superclasses fuel rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
- tvs theta cls tys
- = concatMapM do_one_given $
- classSCSelIds cls
- where
- dict_ids = mkTemplateLocals theta
- this_size = pSizeClassPred cls tys
-
- do_one_given sel_id
- | isUnliftedType sc_pred
- -- NB: class superclasses are never representation-polymorphic,
- -- so isUnliftedType is OK here.
- , not (null tvs && null theta)
- = -- See Note [Equality superclasses in quantified constraints]
- return []
- | otherwise
- = do { given_ev <- newGivenEvVar sc_loc $
- mk_given_desc sel_id sc_pred
- ; assertFuelPrecondition fuel
- $ mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
- where
- sc_pred = classMethodInstTy sel_id tys
-
- -- See Note [Nested quantified constraint superclasses]
- mk_given_desc :: Id -> PredType -> (PredType, EvTerm)
- mk_given_desc sel_id sc_pred
- = (swizzled_pred, swizzled_evterm)
- where
- (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred
- (sc_theta, sc_inner_pred) = splitFunTys sc_rho
-
- all_tvs = tvs `chkAppend` sc_tvs
- all_theta = theta `chkAppend` (map scaledThing sc_theta)
- swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred
-
- -- evar :: forall tvs. theta => cls tys
- -- sel_id :: forall cls_tvs. cls cls_tvs
- -- -> forall sc_tvs. sc_theta => sc_inner_pred
- -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
- swizzled_evterm = EvExpr $
- mkLams all_tvs $
- mkLams dict_ids $
- Var sel_id
- `mkTyApps` tys
- `App` (evId evar `mkVarApps` (tvs ++ dict_ids))
- `mkVarApps` sc_tvs
-
- sc_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.
- -- #10335
-
- | isEqPredClass cls || cls `hasKey` coercibleTyConKey
- = loc -- The only superclasses of ~, ~~, and Coercible are primitive
- -- equalities, and they don't use the GivenSCOrigin mechanism
- -- detailed in Note [Solving superclass constraints] in
- -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win.
-
- | otherwise
- = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) }
-
- -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
- -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in
- -- GHC.Tc.Solver.Interact for why we need depths
- mk_sc_origin :: CtOrigin -> CtOrigin
- mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked)
- = GivenSCOrigin skol_info (sc_depth + 1)
- (already_blocked || newly_blocked skol_info)
-
- mk_sc_origin (GivenOrigin skol_info)
- = -- These cases do not already have a superclass constraint: depth starts at 1
- GivenSCOrigin skol_info 1 (newly_blocked skol_info)
-
- mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $
- ppr evar $$ ppr other_orig
-
- newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size)
- newly_blocked _ = False
-
-mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
- | all noFreeVarsOfType tys
- = return [] -- Wanteds with no variables yield no superclass constraints.
- -- See Note [Improvement from Ground Wanteds]
-
- | otherwise -- Wanted case, just add Wanted superclasses
- -- that can lead to improvement.
- = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $
- concatMapM do_one (immSuperClasses cls tys)
- where
- loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev)
-
- do_one sc_pred
- = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
- ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
- ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
-
-{- Note [Improvement from Ground Wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose class C b a => D a b
-and consider
- [W] D Int Bool
-Is there any point in emitting [W] C Bool Int? No! The only point of
-emitting superclass constraints for W constraints is to get
-improvement, extra unifications that result from functional
-dependencies. See Note [Why adding superclasses can help] above.
-
-But no variables means no improvement; case closed.
--}
-
-mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
- -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
--- Return this constraint, plus its superclasses, if any
--- Precondition: fuel >= 0
-mk_superclasses fuel rec_clss ev tvs theta pred
- | ClassPred cls tys <- classifyPredType pred
- = assertFuelPrecondition fuel $
- mk_superclasses_of fuel rec_clss ev tvs theta cls tys
-
- | otherwise -- Superclass is not a class predicate
- = return [mkNonCanonical ev]
-
-mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
- -> [TyVar] -> ThetaType -> Class -> [Type]
- -> TcS [Ct]
--- Always return this class constraint,
--- and expand its superclasses
--- Precondition: fuel >= 0
-mk_superclasses_of fuel rec_clss ev tvs theta cls tys
- | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
- ; assertFuelPrecondition fuel $ return [mk_this_ct fuel] }
- -- cc_pend_sc of returning ct = fuel
- | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
- , ppr (isCTupleClass cls)
- , ppr rec_clss
- ])
- ; sc_cts <- assertFuelPrecondition fuel $
- mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
- ; return (mk_this_ct doNotExpand : sc_cts) }
- -- doNotExpand: we have expanded this cls's superclasses, so
- -- exhaust the associated constraint's fuel,
- -- to avoid duplicate work
- 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
- mk_this_ct :: ExpansionFuel -> Ct
- mk_this_ct fuel | null tvs, null theta
- = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
- , cc_pend_sc = fuel }
- -- NB: If there is a loop, we cut off, so we have not
- -- added the superclasses, hence cc_pend_sc = fuel
- | otherwise
- = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
- , qci_ev = ev
- , qci_pend_sc = fuel })
-
-
-{- Note [Equality superclasses in quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#15359, #15593, #15625)
- f :: (forall a. theta => a ~ b) => stuff
-
-It's a bit odd to have a local, quantified constraint for `(a~b)`,
-but some people want such a thing (see the tickets). And for
-Coercible it is definitely useful
- f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
- => stuff
-
-Moreover it's not hard to arrange; we just need to look up /equality/
-constraints in the quantified-constraint environment, which we do in
-GHC.Tc.Solver.Interact.doTopReactOther.
-
-There is a wrinkle though, in the case where 'theta' is empty, so
-we have
- f :: (forall a. a~b) => stuff
-
-Now, potentially, the superclass machinery kicks in, in
-makeSuperClasses, giving us a a second quantified constraint
- (forall a. a ~# b)
-BUT this is an unboxed value! And nothing has prepared us for
-dictionary "functions" that are unboxed. Actually it does just
-about work, but the simplifier ends up with stuff like
- case (/\a. eq_sel d) of df -> ...(df @Int)...
-and fails to simplify that any further. And it doesn't satisfy
-isPredTy any more.
-
-So for now we simply decline to take superclasses in the quantified
-case. Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther,
-which looks for primitive equalities specially in the quantified
-constraints.
-
-See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.
-
-
-************************************************************************
-* *
-* Irreducibles canonicalization
-* *
-************************************************************************
--}
-
-canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
--- Precondition: ty not a tuple and no other evidence form
-canIrred ev
- = do { let pred = ctEvPred ev
- ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
- ; (redn, rewriters) <- rewrite ev pred
- ; rewriteEvidence rewriters ev redn $ \ new_ev ->
-
- do { -- Re-classify, in case rewriting has improved its shape
- -- Code is like the canNC, except
- -- that the IrredPred branch stops work
- ; case classifyPredType (ctEvPred new_ev) of
- ClassPred cls tys -> canClassNC new_ev cls tys
- EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so
- -- cannot become EqPreds
- pprPanic "canIrred: EqPred"
- (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2)
- ForAllPred tvs th p -> -- this is highly suspect; Quick Look
- -- should never leave a meta-var filled
- -- in with a polytype. This is #18987.
- do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
- IrredPred {} -> continueWith $
- mkIrredCt IrredShapeReason new_ev } }
-
-{- *********************************************************************
-* *
-* Quantified predicates
-* *
-********************************************************************* -}
-
-{- Note [Quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The -XQuantifiedConstraints extension allows type-class contexts like this:
-
- data Rose f x = Rose x (f (Rose f x))
-
- instance (Eq a, forall b. Eq b => Eq (f b))
- => Eq (Rose f a) where
- (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
-
-Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
-This quantified constraint is needed to solve the
- [W] (Eq (f (Rose f x)))
-constraint which arises form the (==) definition.
-
-The wiki page is
- https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints
-which in turn contains a link to the GHC Proposal where the change
-is specified, and a Haskell Symposium paper about it.
-
-We implement two main extensions to the design in the paper:
-
- 1. We allow a variable in the instance head, e.g.
- f :: forall m a. (forall b. m b) => D (m a)
- Notice the 'm' in the head of the quantified constraint, not
- a class.
-
- 2. We support superclasses to quantified constraints.
- For example (contrived):
- f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
- f x y = x==y
- Here we need (Eq (m a)); but the quantified constraint deals only
- with Ord. But we can make it work by using its superclass.
-
-Here are the moving parts
- * Language extension {-# LANGUAGE QuantifiedConstraints #-}
- and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
-
- * A new form of evidence, EvDFun, that is used to discharge
- such wanted constraints
-
- * checkValidType gets some changes to accept forall-constraints
- only in the right places.
-
- * Predicate.Pred gets a new constructor ForAllPred, and
- and classifyPredType analyses a PredType to decompose
- the new forall-constraints
-
- * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,
- which holds all the Given forall-constraints. In effect,
- such Given constraints are like local instance decls.
-
- * When trying to solve a class constraint, via
- GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts
- so that we include the local Given forall-constraints
- in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.)
-
- * GHC.Tc.Solver.Canonical.canForAll deals with solving a
- forall-constraint. See
- Note [Solving a Wanted forall-constraint]
-
- * We augment the kick-out code to kick out an inert
- forall constraint if it can be rewritten by a new
- type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable
-
-Note that a quantified constraint is never /inferred/
-(by GHC.Tc.Solver.simplifyInfer). A function can only have a
-quantified constraint in its type if it is given an explicit
-type signature.
-
--}
-
-canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
- -> TcS (StopOrContinue Ct)
-canForAllNC ev tvs theta pred
- | isGiven ev -- See Note [Eagerly expand given superclasses]
- , Just (cls, tys) <- cls_pred_tys_maybe
- = do { dflags <- getDynFlags
- ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys
- -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
- ; emitWork (listToBag sc_cts)
- ; canForAll ev doNotExpand }
- -- doNotExpand: as we have already (eagerly) expanded superclasses for this class
-
- | otherwise
- = do { dflags <- getDynFlags
- ; let fuel | Just (cls, _) <- cls_pred_tys_maybe
- , classHasSCs cls = qcsFuel dflags
- -- See invariants (a) and (b) in QCI.qci_pend_sc
- -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
- -- See Note [Quantified constraints]
- | otherwise = doNotExpand
- ; canForAll ev fuel }
- where
- cls_pred_tys_maybe = getClassPredTys_maybe pred
-
-canForAll :: CtEvidence -> ExpansionFuel -> TcS (StopOrContinue Ct)
--- We have a constraint (forall as. blah => C tys)
-canForAll ev fuel
- = do { -- First rewrite it to apply the current substitution
- ; (redn, rewriters) <- rewrite ev (ctEvPred ev)
- ; rewriteEvidence rewriters ev redn $ \ new_ev ->
-
- do { -- Now decompose into its pieces and solve it
- -- (It takes a lot less code to rewrite before decomposing.)
- ; case classifyPredType (ctEvPred new_ev) of
- ForAllPred tvs theta pred
- -> solveForAll new_ev tvs theta pred fuel
- _ -> pprPanic "canForAll" (ppr new_ev)
- } }
-
-solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel
- -> TcS (StopOrContinue Ct)
-solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
- tvs theta pred _fuel
- = -- See Note [Solving a Wanted forall-constraint]
- setSrcSpan (getLclEnvLoc $ ctLocEnv loc) $
- -- This setSrcSpan is important: the emitImplicationTcS uses that
- -- TcLclEnv for the implication, and that in turn sets the location
- -- for the Givens when solving the constraint (#21006)
- do { let empty_subst = mkEmptySubst $ mkInScopeSet $
- tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
- is_qc = IsQC (ctLocOrigin loc)
-
- -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
- -- in GHC.Tc.Utils.TcType
- -- Very like the code in tcSkolDFunType
- ; rec { skol_info <- mkSkolemInfo skol_info_anon
- ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs
- ; let inst_pred = substTy subst pred
- inst_theta = substTheta subst theta
- skol_info_anon = InstSkol is_qc (get_size inst_pred) }
-
- ; given_ev_vars <- mapM newEvVar inst_theta
- ; (lvl, (w_id, wanteds))
- <- pushLevelNoWorkList (ppr skol_info) $
- do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc)
- -- Set the thing to prove to have a ScOrigin, so we are
- -- careful about its termination checks.
- -- See (QC-INV) in Note [Solving a Wanted forall-constraint]
- ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred
- ; return ( ctEvEvId wanted_ev
- , unitBag (mkNonCanonical wanted_ev)) }
-
- ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs
- given_ev_vars wanteds
-
- ; setWantedEvTerm dest IsCoherent $
- EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
- , et_binds = ev_binds, et_body = w_id }
-
- ; stopWith ev "Wanted forall-constraint" }
- where
- -- Getting the size of the head is a bit horrible
- -- because of the special treament for class predicates
- get_size pred = case classifyPredType pred of
- ClassPred cls tys -> pSizeClassPred cls tys
- _ -> pSizeType pred
-
- -- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred fuel
- = do { addInertForAll qci
- ; stopWith ev "Given forall-constraint" }
- where
- qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = pred, qci_pend_sc = fuel }
-
-{- Note [Solving a Wanted forall-constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Solving a wanted forall (quantified) constraint
- [W] df :: forall ab. (Eq a, Ord b) => C x a b
-is delightfully easy. Just build an implication constraint
- forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
-and discharge df thus:
- df = /\ab. \g1 g2. let <binds> in d
-where <binds> is filled in by solving the implication constraint.
-All the machinery is to hand; there is little to do.
-
-The tricky point is about termination: see #19690. We want to maintain
-the invariant (QC-INV):
-
- (QC-INV) Every quantified constraint returns a non-bottom dictionary
-
-just as every top-level instance declaration guarantees to return a non-bottom
-dictionary. But as #19690 shows, it is possible to get a bottom dicionary
-by superclass selection if we aren't careful. The situation is very similar
-to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance;
-and we use the same solution:
-
-* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size))
-* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc)
-
-Both of these things are done in solveForAll. Now the mechanism described
-in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over.
-
-Note [Solving a Given forall-constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a Given constraint
- [G] df :: forall ab. (Eq a, Ord b) => C x a b
-we just add it to TcS's local InstEnv of known instances,
-via addInertForall. Then, if we look up (C x Int Bool), say,
-we'll find a match in the InstEnv.
-
-
-************************************************************************
-* *
- Evidence transformation
-* *
-************************************************************************
--}
-
-rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds]
- -- in GHC.Tc.Types.Constraint
- -> CtEvidence -- ^ old evidence
- -> Reduction -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate
- -> (CtEvidence -> TcS (StopOrContinue Ct))
- -> TcS (StopOrContinue Ct)
--- (rewriteEvidence old_ev new_pred co do_next)
--- Main purpose: create new evidence for new_pred;
--- unless new_pred is cached already
--- * Calls do_next with (new_ev :: new_pred), with same wanted/given 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
--- * Stops if new_ev is already cached
---
--- Old evidence New predicate is Return new evidence
--- flavour of same flavor
--- -------------------------------------------------------------------
--- Wanted Already solved or in inert Stop
--- Not do_next new_evidence
---
--- Given Already in inert Stop
--- Not do_next new_evidence
-
-{- Note [Rewriting with Refl]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the coercion is just reflexivity then you may re-use the same
-evidence 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.
-
-The rewriter preserves type synonyms, so they should appear in new_pred
-as well as in old_pred; that is important for good error messages.
-
-If we are rewriting with Refl, then there are no new rewriters to add to
-the rewriter set. We check this with an assertion.
- -}
-
-
-rewriteEvidence rewriters old_ev (Reduction co new_pred) do_next
- | isReflCo co -- See Note [Rewriting with Refl]
- = assert (isEmptyRewriterSet rewriters) $
- do_next (setCtEvPredType old_ev new_pred)
-
-rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
- (Reduction co new_pred) do_next
- = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
- do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
- ; do_next new_ev }
- where
- -- mkEvCast optimises ReflCo
- new_tm = mkEvCast (evId old_evar)
- (downgradeRole Representational (ctEvRole ev) co)
-
-rewriteEvidence new_rewriters
- ev@(CtWanted { ctev_dest = dest
- , ctev_loc = loc
- , ctev_rewriters = rewriters })
- (Reduction co new_pred) do_next
- = do { mb_new_ev <- newWanted loc rewriters' new_pred
- ; massert (coercionRole co == ctEvRole ev)
- ; setWantedEvTerm dest IsCoherent $
- mkEvCast (getEvExpr mb_new_ev)
- (downgradeRole Representational (ctEvRole ev) (mkSymCo co))
- ; case mb_new_ev of
- Fresh new_ev -> do_next new_ev
- Cached _ -> stopWith ev "Cached wanted" }
- where
- rewriters' = rewriters S.<> new_rewriters
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index c0f7dc7a4968..c952a366d9b2 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -1,48 +1,831 @@
+{-# LANGUAGE MultiWayIf #-}
+
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.Dict (
- doTopReactDict,
+ solveDict, solveDictNC,
checkInstanceOK,
- matchLocalInst, chooseInstance
-
+ matchLocalInst, chooseInstance,
+ makeSuperClasses, mkStrictSuperClasses,
+ solveCallStack -- For GHC.Tc.Solver
) where
import GHC.Prelude
import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.FunDeps
+import GHC.Tc.Instance.Class( safeOverlap, matchEqualityInst )
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
+import GHC.Tc.Types.EvTerm( evCallStack )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.Unify( uType )
-import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey )
+import GHC.Hs.Type( HsIPName(..) )
-import GHC.Core.Type as Type
+import GHC.Core
+import GHC.Core.Type
import GHC.Core.InstEnv ( DFunInstType, Coherence(..) )
import GHC.Core.Class
import GHC.Core.Predicate
+import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Unify ( ruleMatchTyKiX )
+import GHC.Types.Name.Set
import GHC.Types.Var
+import GHC.Types.Id( mkTemplateLocals )
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
-import GHC.Types.Unique( hasKey )
-import GHC.Utils.Monad ( foldlM )
+import GHC.Utils.Monad ( concatMapM, foldlM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Data.Bag
+
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
-import Data.Maybe ( listToMaybe, mapMaybe )
+import Data.Maybe ( listToMaybe, mapMaybe, isJust )
+import Data.Void( Void )
+
+import Control.Monad.Trans.Maybe( MaybeT, runMaybeT )
+import Control.Monad.Trans.Class( lift )
+import Control.Monad( mzero )
+
+
+{- *********************************************************************
+* *
+* Class Canonicalization
+* *
+********************************************************************* -}
+
+solveDictNC :: CtEvidence -> Class -> [Type] -> SolverStage Void
+-- NC: this comes from CNonCanonical or CIrredCan
+-- Precondition: already rewritten by inert set
+solveDictNC ev cls tys
+ = do { simpleStage $ traceTcS "solveDictNC" (ppr (mkClassPred cls tys) $$ ppr ev)
+ ; dict_ct <- canDictCt ev cls tys
+ ; solveDict dict_ct }
+
+solveDict :: DictCt -> SolverStage Void
+-- Preconditions: `tys` are already rewritten by the inert set
+solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ | isEqualityClass cls
+ = solveEqualityDict ev cls tys
+
+ | otherwise
+ = assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
+ do { simpleStage $ traceTcS "solveDict" (ppr dict_ct)
+
+ ; tryInertDicts dict_ct
+ ; tryInstances dict_ct
+
+ -- Try fundeps /after/ tryInstances:
+ -- see (DFL2) in Note [Do fundeps last]
+ ; doLocalFunDepImprovement dict_ct
+ -- doLocalFunDepImprovement does StartAgain if there
+ -- are any fundeps: see (DFL1) in Note [Do fundeps last]
+
+ ; doTopFunDepImprovement dict_ct
+
+ ; tryLastResortProhibitedSuperClass dict_ct
+ ; simpleStage (updInertDicts dict_ct)
+ ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
+
+updInertDicts :: DictCt -> TcS ()
+updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
+
+ -- See Note [Shadowing of implicit parameters]
+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
+ -> updInertCans (updDicts (filterDicts (not_ip_for str_ty)))
+ | otherwise
+ -> return ()
+
+ -- Add the new constraint to the inert set
+ ; updInertCans (updDicts (addDict dict_ct)) }
+ where
+ not_ip_for :: Type -> DictCt -> Bool
+ not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentionsIP str_ty cls tys)
+
+canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt
+-- Once-only processing of Dict constraints:
+-- * expand superclasses
+-- * deal with CallStack
+canDictCt ev cls tys
+ | isGiven ev -- See Note [Eagerly expand given superclasses]
+ = Stage $
+ do { dflags <- getDynFlags
+ ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys
+ -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
+ ; emitWork (listToBag sc_cts)
+
+ ; continueWith (DictCt { di_ev = ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = doNotExpand }) }
+ -- doNotExpand: We have already expanded superclasses for /this/ dict
+ -- so set the fuel to doNotExpand to avoid repeating expansion
+
+ | CtWanted { ctev_rewriters = rewriters } <- ev
+ , Just ip_name <- isCallStackPred cls tys
+ , isPushCallStackOrigin orig
+ -- If we're given a CallStack constraint that arose from a function
+ -- call, we need to push the current call-site onto the stack instead
+ -- of solving it directly from a given.
+ -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+ -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types
+ = Stage $
+ 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]
+ -- in GHC.Tc.Types.Evidence
+
+ ; new_ev <- newWantedEvVarNC new_loc rewriters pred
+
+ -- Then we solve the wanted by pushing the call-site
+ -- onto the newly emitted CallStack
+ ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
+ (ctLocSpan loc) (ctEvExpr new_ev)
+ ; solveCallStack ev ev_cs
+
+ ; continueWith (DictCt { di_ev = new_ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = doNotExpand }) }
+ -- doNotExpand: No superclasses for class CallStack
+ -- See invariants in CDictCan.cc_pend_sc
+
+ | otherwise
+ = Stage $
+ do { dflags <- getDynFlags
+ ; let fuel | classHasSCs cls = wantedsFuel dflags
+ | otherwise = doNotExpand
+ -- See Invariants in `CCDictCan.cc_pend_sc`
+ ; continueWith (DictCt { di_ev = ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = fuel }) }
+ where
+ loc = ctEvLoc ev
+ orig = ctLocOrigin loc
+ pred = ctEvPred ev
+
+solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
+-- Also called from GHC.Tc.Solver when defaulting call stacks
+solveCallStack ev ev_cs
+ -- 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]
+ = do { cs_tm <- evCallStack ev_cs
+ ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
+ ; setEvBindIfWanted ev IsCoherent ev_tm }
+
+
+{- Note [Shadowing of implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we add a new /given/ implicit parameter to the inert set, it /replaces/
+any existing givens for the same implicit parameter. This makes a difference
+in two places:
+
+* In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have
+ (?x :: ty) in the inert set and an identical (?x :: ty) as the work item.
+
+* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any
+ existing [G] (?x :: ty'), regardless of ty'.
+
+* Wrinkle (SIP1): we must be careful of superclasses. 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). #14218.
+
+ We deal with this by arranging that when we add [G] (?x::ty) we delete any
+ existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
+ with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
+
+ An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+ But it could happen for `class xx => D xx where ...` and the constraint D
+ (?x :: int). This corner (constraint-kinded variables instantiated with
+ implicit parameter constraints) is not well explorered.
+
+ Example in #14218.
+
+ The code that accounts for (SIP1) is in updInertDicts, and the call to
+ GHC.Core.Predicate.mentionsIP.
+
+* Wrinkle (SIP2): we delete dictionaries in inert_dicts, but we don't need to
+ look in inert_solved_dicts. They are never implicit parameters. See
+ Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
+
+Example 1:
+
+Suppose we have (typecheck/should_compile/ImplicitParamFDs)
+ flub :: (?x :: Int) => (Int, Integer)
+ flub = (?x, let ?x = 5 in ?x)
+When we are checking the last ?x occurrence, we guess its type to be a fresh
+unification variable alpha and emit an (IP "x" alpha) constraint. But the given
+(?x :: Int) has been translated to an IP "x" Int constraint, which has a
+functional dependency from the name to the type. So if that (?x::Int) is still
+in the inert set, we'd get a fundep interaction that tells us that alpha ~ Int,
+and we get a type error. This is bad. The "replacement" semantics stops this
+happening.
+
+Example 2:
+
+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. The "replacement" semantics for implicit parameters
+does this.
+
+Example 3:
+
+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.
+
+See ticket #17104 for a rather tricky example of this overriding
+behaviour.
+
+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
+ parameter---this 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.
+-}
+
+
+{- ******************************************************************************
+* *
+ solveEqualityDict
+* *
+****************************************************************************** -}
+
+{- Note [Solving equality classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (~), which behaves as if it was defined like this:
+ class a ~# b => a ~ b
+ instance a ~# b => a ~ b
+There are two more similar "equality classes" like this. The full list is
+ * (~) eqTyCon
+ * (~~) heqTyCon
+ * Coercible coercibleTyCon
+(See Note [The equality types story] in GHC.Builtin.Types.Prim.)
+
+(EQC1) For Givens, when expanding the superclasses of a equality class,
+ we can /replace/ the constraint with its superclasses (which, remember, are
+ equally powerful) rather than /adding/ them. This can make a huge difference.
+ Consider T17836, which has a constraint like
+ forall b,c. a ~ (b,c) =>
+ forall d,e. c ~ (d,e) =>
+ ...etc...
+ If we just /add/ the superclasses of [G] g1:a ~ (b,c), we'll put
+ [G] g1:(a~(b,c)) in the inert set and emit [G] g2:a ~# (b,c). That will
+ kick out g1, and it'll be re-inserted as [G] g1':(b,c)~(b,c) which does
+ no good to anyone. When the implication is deeply nested, this has
+ quadratic cost, and no benefit. Just replace!
+
+ (This can have a /big/ effect: test T17836 involves deeply-nested GADT
+ pattern matching. Its compile-time allocation decreased by 40% when
+ I added the "replace" rather than "add" semantics.)
+
+(EQC2) 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.
+
+Conclusion: we have a special solver pipeline for equality-class constraints,
+`solveEqualityDict`. It aggressively decomposes the boxed equality constraint
+into an unboxed coercion, both for Givens and Wanteds, and /replaces/ the
+boxed equality constraint with the unboxed one, so that the inert set never
+contains the boxed one.
+
+Note [Solving tuple constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I tried treating tuple constraints, such as (% Eq a, Show a %), rather like
+equality-class constraints (see Note [Solving equality classes]). That is, by
+eagerly decomposing tuple-constraints into their component (Eq a) and (Show a).
+
+But discarding the tuple Given (which "replacing" does) means that we may
+have to reconstruct it for a recursive call. For example
+ f :: (% Eq a, Show a %) => blah
+ f x = ....(f x')....
+If we decomposed eagerly we'd get
+ f = \(d : (% Eq a, Show a %)).
+ let de = fst d
+ ds = snd d
+ in ....(f (% de, ds %))...
+and the optimiser may not be clever enough to transform (f (% de, ds %)) into
+(f d). See #10359 and its test case, and #23398. (This issue is less pressing for
+equality classes because they have to be unpacked strictly, so CSE-ing away
+the reconstruction works fine.
+
+So at the moment we don't decompose tuple constraints eagerly; instead we mostly
+just treat them like other constraints.
+* Given tuples are decomposed via their superclasses, in `canDictCt`. So
+ [G] (% Eq a, Show a %)
+ has superclasses
+ [G] Eq a, [G] Show a
+
+* Wanted tuples are decomposed via a built-in "instance". See
+ `GHC.Tc.Instance.Class.matchCTuple`
+
+There is a bit of special treatment: search for isCTupleClass.
+-}
+
+solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void
+-- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible
+solveEqualityDict ev cls tys
+ | CtWanted { ctev_dest = dest } <- ev
+ = Stage $
+ do { let (data_con, role, t1, t2) = matchEqualityInst cls tys
+ -- Unify t1~t2, putting anything that can't be solved
+ -- immediately into the work list
+ ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv ->
+ uType uenv t1 t2
+ -- Set d :: (t1~t2) = Eq# co
+ ; setWantedEvTerm dest IsCoherent $
+ evDataConApp data_con tys [Coercion co]
+ ; stopWith ev "Solved wanted lifted equality" }
+
+ | CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev
+ , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass
+ = Stage $
+ do { let sc_pred = classMethodInstTy sel_id tys
+ ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id
+ ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr)
+ ; startAgainWith (mkNonCanonical given_ev) }
+ | otherwise
+ = pprPanic "solveEqualityDict" (ppr cls)
+
+{- ******************************************************************************
+* *
+ 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
+top-level 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 top-level 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 (#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 (3-1). Really we should now rewrite to reduce the (3-1) 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 (3-1)) 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: 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 FlexibleInstances #-}
+ {-# LANGUAGE MultiParamTypeClasses #-}
+ module B where
+
+ import A
+
+ instance A a where
+ int _ = 1
+
+ instance C a [b] where
+ m _ = id
+
+=========
+ {-# LANGUAGE FlexibleContexts #-}
+ {-# LANGUAGE FlexibleInstances #-}
+ {-# LANGUAGE IncoherentInstances #-}
+ {-# LANGUAGE MultiParamTypeClasses #-}
+ 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 short-cut solver is
+ try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
+ -> CtEvidence -- Solve this
+ -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+Note that:
+
+* The CtEvidence is the goal to be solved
+
+* The MaybeT manages early failure if we find a subgoal that
+ cannot be solved from instances.
+
+* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
+ state that allows try_solve_from_instance to augment 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 #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.
+
+Note [No Given/Given fundeps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not create constraints from:
+* Given/Given interactions via functional dependencies or type family
+ injectivity annotations.
+* Given/instance fundep interactions via functional dependencies or
+ type family injectivity annotations.
+
+In this Note, all these interactions are called just "fundeps".
+
+We ingore such fundeps for several reasons:
+
+1. These fundeps will never serve a purpose in accepting more
+ programs: Given constraints do not contain metavariables that could
+ be unified via exploring fundeps. They *could* be useful in
+ discovering inaccessible code. However, the constraints will be
+ Wanteds, and as such will cause errors (not just warnings) if they
+ go unsolved. Maybe there is a clever way to get the right
+ inaccessible code warnings, but the path forward is far from
+ clear. #12466 has further commentary.
+
+2. Furthermore, here is a case where a Given/instance interaction is actively
+ harmful (from dependent/should_compile/RaeJobTalk):
+
+ type family a == b :: Bool
+ type family Not a = r | r -> a where
+ Not False = True
+ Not True = False
+
+ [G] Not (a == b) ~ True
+
+ Reacting this Given with the equations for Not produces
+
+ [W] a == b ~ False
+
+ This is indeed a true consequence, and would make sense as a fresh Given.
+ But we don't have a way to produce evidence for fundeps, as a Wanted it
+ is /harmful/: we can't prove it, and so we'll report an error and reject
+ the program. (Previously fundeps gave rise to Deriveds, which
+ carried no evidence, so it didn't matter that they could not be proved.)
+
+3. #20922 showed a subtle different problem with Given/instance fundeps.
+ type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where
+ ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss
+ ...
+
+ tclevel = 4
+ [G] ZipCons is1 iss ~ (i : is2) : jss
+
+ (The tclevel=4 means that this Given is at level 4.) The fundep tells us that
+ 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification
+ variable; we don't know what type it stands for. So we would emit
+ [W] iss ~ is2 : beta
+
+ Again we can't prove that equality; and worse we'll rewrite iss to
+ (is2:beta) in deeply nested constraints inside this implication,
+ where beta is untouchable (under other equality constraints), leading
+ to other insoluble constraints.
+
+The bottom line: since we have no evidence for them, we should ignore Given/Given
+and Given/instance fundeps entirely.
+-}
+
+tryInertDicts :: DictCt -> SolverStage ()
+tryInertDicts dict_ct
+ = Stage $ do { inerts <- getInertCans
+ ; try_inert_dicts inerts dict_ct }
+
+try_inert_dicts :: InertCans -> DictCt -> TcS (StopOrContinue ())
+try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys })
+ | Just dict_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
+ , let ev_i = dictCtEvidence dict_i
+ loc_i = ctEvLoc ev_i
+ loc_w = ctEvLoc ev_w
+ = -- 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"
+
+ -- Next see if we are in "loopy-superclass" land. If so,
+ -- we don't want to replace the (Given) inert with the
+ -- (Wanted) work-item, or vice versa; we want to hang on
+ -- to both, and try to solve the work-item via an instance.
+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
+ else if prohibitedSuperClassSolve loc_i loc_w
+ then continueWith ()
+ else
+ do { -- The short-cut solver didn't fire, and loopy superclasses
+ -- are dealt with, so we can either solve
+ -- the inert from the work-item or vice-versa.
+ ; case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of
+ KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w)
+ ; setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
+ ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) }
+ KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w)
+ ; setEvBindIfWanted ev_i IsCoherent (ctEvTerm ev_w)
+ ; updInertCans (updDicts $ delDict dict_w)
+ ; continueWith () } } }
+
+ | otherwise
+ = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys)
+ ; continueWith () }
+
+-- 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 (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
+
+ , 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 top-level proof.
+ -- See Note [Shortcut solving: incoherence]
+
+ , gopt Opt_SolveConstantDicts dflags
+ -- Enabled by the -fsolve-constant-dicts flag
+
+ = do { ev_binds_var <- getTcEvBindsVar
+ ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
+ getTcEvBindsMap ev_binds_var
+ ; solved_dicts <- getSolvedDicts
+
+ ; mb_stuff <- runMaybeT $
+ try_solve_from_instance (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 well-staged 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]
+ :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
+ -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+ try_solve_from_instance (ev_binds, solved_dicts) ev
+ | let pred = ctEvPred ev
+ , ClassPred cls tys <- classifyPredType pred
+ = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
+ ; case inst_res of
+ OneInst { cir_new_theta = preds
+ , cir_mk_ev = mk_ev
+ , cir_coherence = coherence
+ , cir_what = what }
+ | safeOverlap what
+ , all isTyFamFree preds -- Note [Shortcut solving: type families]
+ -> do { let solved_dicts' = addSolvedDict cls tys ev solved_dicts
+ -- 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)
+ ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred
+ ; lift $ checkReductionDepth loc' pred
+
+
+ ; evc_vs <- mapM (new_wanted_cached ev loc' 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) coherence ev_tm
+
+ ; foldlM try_solve_from_instance (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 :: CtEvidence -> CtLoc
+ -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
+ new_wanted_cached ev_w loc 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 (ctEvRewriters ev_w) pty
+ | otherwise = mzero
{- *******************************************************************
* *
@@ -50,12 +833,17 @@ import Data.Maybe ( listToMaybe, mapMaybe )
* *
**********************************************************************-}
-doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+tryInstances :: DictCt -> SolverStage ()
+tryInstances dict_ct
+ = Stage $ do { inerts <- getInertSet
+ ; try_instances inerts dict_ct }
+
+try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ())
-- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
- , cc_tyargs = xis })
+try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls
+ , di_tys = xis })
| isGiven ev -- Never use instances for Given constraints
- = continueWith work_item
+ = continueWith ()
-- See Note [No Given/Given fundeps]
| Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached
@@ -68,52 +856,15 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
; case lkup_res of
OneInst { cir_what = what }
-> do { insertSafeOverlapFailureTcS what work_item
- ; addSolvedDict what ev cls xis
+ ; updSolvedDicts what work_item
; chooseInstance ev lkup_res }
_ -> -- NoInstance or NotSure
-- We didn't solve it; so try functional dependencies
- tryFunDeps work_item }
+ continueWith () }
where
dict_loc = ctEvLoc ev
-doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
-
-tryFunDeps :: Ct -> TcS (StopOrContinue Ct)
--- Try functional dependencies
--- We do local improvement, then try top level; and we do all this last
--- See Note [Do fundeps last]
-tryFunDeps work_item
- = do { improved <- doLocalFunDepImprovement work_item
- ; if improved then startAgainWith work_item else
-
- do { improved <- doTopFunDepImprovement work_item
- ; if improved then startAgainWith work_item else
-
- do { inerts <- getTcSInerts
- ; tryLastResortProhibitedSuperclass inerts work_item } } }
-
-tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct)
--- ^ As a last resort, we TEMPORARILY allow a prohibited superclass solve,
--- emitting a loud warning when doing so: we might be creating non-terminating
--- evidence (as we are in T22912 for example).
---
--- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
-tryLastResortProhibitedSuperclass inerts
- work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis })
- | let loc_w = ctEvLoc ev_w
- orig_w = ctLocOrigin loc_w
- , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted
- , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis
- , let ev_i = ctEvidence ct_i
- , isGiven ev_i
- = do { setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
- ; ctLocWarnTcS loc_w $
- TcRnLoopySuperclassSolve loc_w (ctPred work_item)
- ; return $ Stop ev_w (text "Loopy superclass") }
-tryLastResortProhibitedSuperclass _ work_item
- = continueWith work_item
-
-chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct)
+chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue a)
chooseInstance work_item
(OneInst { cir_new_theta = theta
, cir_what = what
@@ -165,10 +916,13 @@ matchClassInst dflags inerts clas tys loc
-- whether top level, or local quantified constraints.
-- See Note [Instance and Given overlap]
| not (xopt LangExt.IncoherentInstances dflags)
- , not (naturallyCoherentClass clas)
+ , not (isCTupleClass clas)
+ -- It is always safe to unpack constraint tuples
+ -- And if we don't do so, we may never solve it at all
+ -- See Note [Solving tuple constraints]
, not (noMatchableGivenDicts inerts loc clas tys)
= do { traceTcS "Delaying instance application" $
- vcat [ text "Work item=" <+> pprClassPred clas tys ]
+ vcat [ text "Work item:" <+> pprClassPred clas tys ]
; return NotSure }
| otherwise
@@ -191,18 +945,6 @@ matchClassInst dflags inerts clas tys loc
where
pred = mkClassPred clas tys
--- | 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 types story] in GHC.Builtin.Types.Prim.
-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:
@@ -282,48 +1024,6 @@ All of this is disgustingly delicate, so to discourage people from writing
simplifiable class givens, we warn about signatures that contain them;
see GHC.Tc.Validity Note [Simplifiable given constraints].
-Note [Naturally coherent classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A few built-in 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 GHC.Builtin.Types.Prim.)
-
-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 GHC.Tc.Solver.Types
- Note [Tuples hiding implicit parameters], we may have a constraint
- [W] (?x::Int, C a)
- with an exactly-matching 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 #14218
-
-Examples: 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.
Note [Local instances and incoherence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -356,7 +1056,7 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
-- Look up the predicate in Given quantified constraints,
-- which are effectively just local instance declarations.
matchLocalInst pred loc
- = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts
+ = do { inerts@(IS { inert_cans = ics }) <- getInertSet
; case match_local_inst inerts (inert_insts ics) of
{ ([], []) -> do { traceTcS "No local instance for" (ppr pred)
; return NoInstance }
@@ -591,9 +1291,41 @@ Test cases:
Historical note: a previous solution was to instead pick the local instance
with the least superclass depth (see Note [Replacement vs keeping]),
but that doesn't work for the example from #22216.
+-}
+{- *******************************************************************
+* *
+ Last resort prohibited superclass
+* *
+**********************************************************************-}
-************************************************************************
+tryLastResortProhibitedSuperClass :: DictCt -> SolverStage ()
+-- ^ As a last resort, we TEMPORARILY allow a prohibited superclass solve,
+-- emitting a loud warning when doing so: we might be creating non-terminating
+-- evidence (as we are in T22912 for example).
+--
+-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
+tryLastResortProhibitedSuperClass dict_ct
+ = Stage $ do { inerts <- getInertCans
+ ; last_resort inerts dict_ct }
+
+last_resort :: InertCans -> DictCt -> TcS (StopOrContinue ())
+last_resort inerts (DictCt { di_ev = ev_w, di_cls = cls, di_tys = xis })
+ | let loc_w = ctEvLoc ev_w
+ orig_w = ctLocOrigin loc_w
+ , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted
+ , Just ct_i <- lookupInertDict inerts loc_w cls xis
+ , let ev_i = dictCtEvidence ct_i
+ , isGiven ev_i
+ = do { setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
+ ; ctLocWarnTcS loc_w $
+ TcRnLoopySuperclassSolve loc_w (ctEvPred ev_w)
+ ; return $ Stop ev_w (text "Loopy superclass") }
+ | otherwise
+ = continueWith ()
+
+
+{- *********************************************************************
* *
* Functional dependencies, instantiation of equations
* *
@@ -779,7 +1511,7 @@ and never generate `SurelyApart` and always return a `MaybeApart Subst`
instead.
The same alternative plan would work for type-family injectivity constraints:
-see Note [Improvement orientation].
+see Note [Improvement orientation] in GHC.Tc.Solver.Equality.
--- End of Alternative plan (1) ---
--- Alternative plan (2) ---
@@ -807,18 +1539,21 @@ Consider T4254b:
foo :: forall a b. (a~Int,FD a b) => a -> Bool
foo = op
-From the ambiguity check on the type signature we get
- [G] FD Int b
- [W] FD Int beta
-Interacting these gives beta:=b; then we start again and solve without
-trying fundeps between the new [W] FD Int b and the top-level instance.
-If we did, we'd generate [W] b ~ Bool, which fails.
+(DFL1) Try local fundeps first.
+ From the ambiguity check on the type signature we get
+ [G] FD Int b
+ [W] FD Int beta
+ Interacting these gives beta:=b; then we start again and solve without
+ trying fundeps between the new [W] FD Int b and the top-level instance.
+ If we did, we'd generate [W] b ~ Bool, which fails.
+
+(DFL2) Try solving from top-level instances before fundeps
+ From the definition `foo = op` we get
+ [G] FD Int b
+ [W] FD Int Bool
+ We solve this from the top level instance before even trying fundeps.
+ If we did try fundeps, we'd generate [W] b ~ Bool, which fails.
-From the definition `foo = op` we get
- [G] FD Int b
- [W] FD Int Bool
-We solve this from the top level instance before even trying fundeps.
-If we did try fundeps, we'd generate [W] b ~ Bool, which fails.
Note [Weird fundeps]
~~~~~~~~~~~~~~~~~~~~
@@ -842,17 +1577,20 @@ as the fundeps.
#7875 is a case in point.
-}
-doLocalFunDepImprovement :: Ct -> TcS Bool
+doLocalFunDepImprovement :: DictCt -> SolverStage ()
-- Add wanted constraints from type-class functional dependencies.
-doLocalFunDepImprovement (CDictCan { cc_ev = work_ev, cc_class = cls })
- = do { inerts <- getInertCans
- ; foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls) }
+doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls })
+ = Stage $
+ do { inerts <- getInertCans
+ ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls)
+ ; if imp then startAgainWith (CDictCan dict_ct)
+ else continueWith () }
where
work_pred = ctEvPred work_ev
work_loc = ctEvLoc work_ev
- add_fds :: Bool -> Ct -> TcS Bool
- add_fds so_far inert_ct
+ add_fds :: Bool -> DictCt -> TcS Bool
+ add_fds so_far (DictCt { di_ev = inert_ev })
| isGiven work_ev && isGiven inert_ev
-- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]
= return so_far
@@ -869,10 +1607,9 @@ doLocalFunDepImprovement (CDictCan { cc_ev = work_ev, cc_class = cls })
; return (so_far || unifs)
}
where
- inert_ev = ctEvidence inert_ct
inert_pred = ctEvPred inert_ev
inert_loc = ctEvLoc inert_ev
- inert_rewriters = ctRewriters inert_ct
+ inert_rewriters = ctEvRewriters inert_ev
derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth`
ctl_depth inert_loc
, ctl_origin = FunDepOrigin1 work_pred
@@ -882,18 +1619,22 @@ doLocalFunDepImprovement (CDictCan { cc_ev = work_ev, cc_class = cls })
(ctLocOrigin inert_loc)
(ctLocSpan inert_loc) }
-doLocalFunDepImprovement work_item = pprPanic "doLocalFunDepImprovement" (ppr work_item)
-
-doTopFunDepImprovement :: Ct -> TcS Bool
+doTopFunDepImprovement :: DictCt -> SolverStage ()
-- Try to functional-dependency improvement between the constraint
-- and the top-level instance declarations
-- See Note [Fundeps with instances, and equality orientation]
-- See also Note [Weird fundeps]
-doTopFunDepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = xis })
- = do { traceTcS "try_fundeps" (ppr work_item)
+doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
+ | isGiven ev -- No improvement for Givens
+ = Stage $ continueWith ()
+ | otherwise
+ = Stage $
+ do { traceTcS "try_fundeps" (ppr dict_ct)
; instEnvs <- getInstEnvs
; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
- ; emitFunDepWanteds ev fundep_eqns }
+ ; imp <- emitFunDepWanteds ev fundep_eqns
+ ; if imp then startAgainWith (CDictCan dict_ct)
+ else continueWith () }
where
dict_pred = mkClassPred cls xis
dict_loc = ctEvLoc ev
@@ -907,4 +1648,514 @@ doTopFunDepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyar
inst_pred inst_loc }
, emptyRewriterSet )
-doTopFunDepImprovement work_item = pprPanic "doTopFunDepImprovement" (ppr work_item)
+
+{- *********************************************************************
+* *
+* Superclasses
+* *
+********************************************************************* -}
+
+{- 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], 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 [W] (C Int beta) constraint. We won't use the evidence,
+ but it may lead to unification.
+
+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 (#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 non-canonical 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 GHC.Tc.Utils.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 superclasses for new /given/
+ /non-canonical/ constraints (canClassNC does this). As #12175
+ showed, a type-family 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 GHC.Tc.Types.Constraint)
+ try harder: take both the Givens and Wanteds, and expand
+ superclasses again. See the calls to expandSuperClasses in
+ GHC.Tc.Solver.simpl_loop and solveWanteds.
+
+ This may succeed in generating (a finite number of) extra Givens,
+ and extra Wanteds. Both may help the proof.
+
+3a An important wrinkle: only expand Givens from the current level.
+ Two reasons:
+ - We only want to expand it once, and that is best done at
+ the level it is bound, rather than repeatedly at the leaves
+ of the implication tree
+ - We may be inside a type where we can't create term-level
+ evidence anyway, so we can't superclass-expand, say,
+ (a ~ b) to get (a ~# b). This happened in #15290.
+
+4. Go round to (2) again. This loop (2,3,4) is implemented
+ in GHC.Tc.Solver.simpl_loop.
+
+The cc_pend_sc field 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 > 0
+(i.e. isPendingScDict holds).
+See Note [Expanding Recursive Superclasses and ExpansionFuel]
+
+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 -XNoUndecidableSuperClasses
+ 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 self-same
+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 cc_pend_sc has pending
+expansion fuel.)
+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
+GHC.Tc.Solver.InertSet. 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 non-confluent proofs, but to stop our users
+complaining we expand one layer in advance.
+
+See Note [Instance and Given overlap].
+
+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.
+
+This same scenario happens with quantified constraints, whose superclasses
+are also eagerly expanded. Test case: typecheck/should_compile/T16502b
+These are handled in canForAllNC, analogously to 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 [W] beta~b will let us solve it.
+
+ -- Example 2 (similar but using a type-equality 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
+ [W] F a ~ beta
+ Now we get [W] 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 hence 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 superclass
+ [W] L a beta. Now using fundeps, combine with [G] L a b to get
+ [W] beta ~ b
+ which is what we want.
+
+Note [Danger of adding superclasses during solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's a serious, but now out-dated example, from #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
+ [W] RealOf e ~ fuv
+ [W] 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.
+
+Note [Nested quantified constraint superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (typecheck/should_compile/T17202)
+
+ class C1 a
+ class (forall c. C1 c) => C2 a
+ class (forall b. (b ~ F a) => C2 a) => C3 a
+
+Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass
+to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a
+superclass, as well. But we now must be careful: we cannot just add
+(forall c. C1 c) as a Given, because we need to remember g2's context.
+That new constraint is Given only when forall b. (b ~ F a) is true.
+
+It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c),
+but that's problematic, because it's nested, and ForAllPred is not capable
+of representing a nested quantified constraint. (We could change ForAllPred
+to allow this, but the solution in this Note is much more local and simpler.)
+
+So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c).
+
+More generally, if we are expanding the superclasses of
+ g0 :: forall tvs. theta => cls tys
+and find a superclass constraint
+ forall sc_tvs. sc_theta => sc_inner_pred
+we must have a selector
+ sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred
+and thus build
+ g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
+ g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.
+ sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids
+
+Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the
+last bound variables and the last arguments. This avoids the need to produce
+the sc_theta_ids at all. So our final construction is
+
+ g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.
+ sel_id tys (g0 tvs theta_ids) sc_tvs
+
+ -}
+
+makeSuperClasses :: [Ct] -> TcS [Ct]
+-- Returns strict superclasses, transitively, see Note [The superclass story]
+-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.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 constraint's superclass will consume a unit of fuel
+-- Preconditions on `cts`: 1. They are either `CDictCan` or `CQuantCan`
+-- 2. Their fuel (stored in cc_pend_sc or qci_pend_sc) is > 0
+makeSuperClasses cts = concatMapM go cts
+ where
+ go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel }))
+ = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses fuel ev [] [] cls tys
+ go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
+ = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
+ -- class pred heads
+ assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses fuel ev tvs theta cls tys
+ where
+ (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
+ go ct = pprPanic "makeSuperClasses" (ppr ct)
+
+mkStrictSuperClasses
+ :: ExpansionFuel -> CtEvidence
+ -> [TyVar] -> ThetaType -- These two args are non-empty only when taking
+ -- superclasses of a /quantified/ constraint
+ -> Class -> [Type] -> TcS [Ct]
+-- Return constraints for the strict superclasses of
+-- ev :: forall as. theta => cls tys
+-- Precondition: fuel > 0
+-- Postcondition: fuel for recursive superclass ct is one unit less than cls fuel
+mkStrictSuperClasses fuel ev tvs theta cls tys
+ = mk_strict_superclasses (consumeFuel fuel) (unitNameSet (className cls))
+ ev tvs theta cls tys
+
+mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
+ -> [TyVar] -> ThetaType
+ -> 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
+-- The caller of this function is supposed to perform fuel book keeping
+-- Precondition: fuel >= 0
+mk_strict_superclasses _ _ _ _ _ cls _
+ | isEqualityClass cls
+ = return []
+
+mk_strict_superclasses fuel rec_clss
+ ev@(CtGiven { ctev_evar = evar, ctev_loc = loc })
+ tvs theta cls tys
+ = -- Given case
+ do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc))
+ ; concatMapM do_one_given (classSCSelIds cls) }
+ where
+ dict_ids = mkTemplateLocals theta
+ this_size = pSizeClassPred cls tys
+
+ do_one_given sel_id
+ | isUnliftedType sc_pred
+ -- NB: class superclasses are never representation-polymorphic,
+ -- so isUnliftedType is OK here.
+ , not (null tvs && null theta)
+ = -- See Note [Equality superclasses in quantified constraints]
+ return []
+ | otherwise
+ = do { given_ev <- newGivenEvVar sc_loc $
+ mk_given_desc sel_id sc_pred
+ ; assertFuelPrecondition fuel $
+ mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
+ where
+ sc_pred = classMethodInstTy sel_id tys
+
+ -- See Note [Nested quantified constraint superclasses]
+ mk_given_desc :: Id -> PredType -> (PredType, EvTerm)
+ mk_given_desc sel_id sc_pred
+ = (swizzled_pred, swizzled_evterm)
+ where
+ (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred
+ (sc_theta, sc_inner_pred) = splitFunTys sc_rho
+
+ all_tvs = tvs `chkAppend` sc_tvs
+ all_theta = theta `chkAppend` (map scaledThing sc_theta)
+ swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred
+
+ -- evar :: forall tvs. theta => cls tys
+ -- sel_id :: forall cls_tvs. cls cls_tvs
+ -- -> forall sc_tvs. sc_theta => sc_inner_pred
+ -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
+ swizzled_evterm = EvExpr $
+ mkLams all_tvs $
+ mkLams dict_ids $
+ Var sel_id
+ `mkTyApps` tys
+ `App` (evId evar `mkVarApps` (tvs ++ dict_ids))
+ `mkVarApps` sc_tvs
+
+ sc_loc | isCTupleClass cls = loc
+ | otherwise = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) }
+ -- isCTupleClass: we don't want tuples to mess up the size calculations
+ -- of Note [Solving superclass constraints]. For tuple predicates, this
+ -- matters, because their size can be large, and we don't want to add a
+ -- big class to the size of the dictionaries in the chain. When we get
+ -- down to a base predicate, we'll include its size. See #10335.
+ -- See Note [Solving tuple constraints]
+
+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
+ -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in
+ -- GHC.Tc.Solver.InertSet for why we need depths
+ mk_sc_origin :: CtOrigin -> CtOrigin
+ mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked)
+ = GivenSCOrigin skol_info (sc_depth + 1)
+ (already_blocked || newly_blocked skol_info)
+
+ mk_sc_origin (GivenOrigin skol_info)
+ = -- These cases do not already have a superclass constraint: depth starts at 1
+ GivenSCOrigin skol_info 1 (newly_blocked skol_info)
+
+ mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $
+ ppr evar $$ ppr other_orig
+
+ newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size)
+ newly_blocked _ = False
+
+-- Wanted case
+mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
+ | all noFreeVarsOfType tys
+ = return [] -- Wanteds with no variables yield no superclass constraints.
+ -- See Note [Improvement from Ground Wanteds]
+
+ | otherwise -- Wanted case, just add Wanted superclasses
+ -- that can lead to improvement.
+ = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $
+ concatMapM do_one (immSuperClasses cls tys)
+ where
+ loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev)
+
+ do_one sc_pred
+ = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
+ ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
+ ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
+
+{- Note [Improvement from Ground Wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose class C b a => D a b
+and consider
+ [W] D Int Bool
+Is there any point in emitting [W] C Bool Int? No! The only point of
+emitting superclass constraints for W constraints is to get
+improvement, extra unifications that result from functional
+dependencies. See Note [Why adding superclasses can help] above.
+
+But no variables means no improvement; case closed.
+-}
+
+mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
+ -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
+-- Return this constraint, plus its superclasses, if any
+-- Precondition: fuel >= 0
+mk_superclasses fuel rec_clss ev tvs theta pred
+ | ClassPred cls tys <- classifyPredType pred
+ = assertFuelPrecondition fuel $
+ mk_superclasses_of fuel rec_clss ev tvs theta cls tys
+
+ | otherwise -- Superclass is not a class predicate
+ = return [mkNonCanonical ev]
+
+mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
+ -> [TyVar] -> ThetaType -> Class -> [Type]
+ -> TcS [Ct]
+-- Always return this class constraint,
+-- and expand its superclasses
+-- Precondition: fuel >= 0
+mk_superclasses_of fuel rec_clss ev tvs theta cls tys
+ | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
+ ; assertFuelPrecondition fuel $ return [mk_this_ct fuel] }
+ -- cc_pend_sc of returning ct = fuel
+ | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
+ , ppr (isCTupleClass cls)
+ , ppr rec_clss
+ ])
+ ; sc_cts <- assertFuelPrecondition fuel $
+ mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
+ ; return (mk_this_ct doNotExpand : sc_cts) }
+ -- doNotExpand: we have expanded this cls's superclasses, so
+ -- exhaust the associated constraint's fuel,
+ -- to avoid duplicate work
+ 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
+
+ mk_this_ct :: ExpansionFuel -> Ct
+ -- We can't use CNonCanonical here because we need to tradk the fuel
+ mk_this_ct fuel | null tvs, null theta
+ = CDictCan (DictCt { di_ev = ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = fuel })
+ -- NB: If there is a loop, we cut off, so we have not
+ -- added the superclasses, hence cc_pend_sc = fuel
+ | otherwise
+ = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
+ , qci_ev = ev, qci_pend_sc = fuel })
+
+
+{- Note [Equality superclasses in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#15359, #15593, #15625)
+ f :: (forall a. theta => a ~ b) => stuff
+
+It's a bit odd to have a local, quantified constraint for `(a~b)`,
+but some people want such a thing (see the tickets). And for
+Coercible it is definitely useful
+ f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
+ => stuff
+
+Moreover it's not hard to arrange; we just need to look up /equality/
+constraints in the quantified-constraint environment, which we do in
+GHC.Tc.Solver.Equality.tryQCsEqCt.
+
+There is a wrinkle though, in the case where 'theta' is empty, so
+we have
+ f :: (forall a. a~b) => stuff
+
+Now, potentially, the superclass machinery kicks in, in
+makeSuperClasses, giving us a a second quantified constraint
+ (forall a. a ~# b)
+BUT this is an unboxed value! And nothing has prepared us for
+dictionary "functions" that are unboxed. Actually it does just
+about work, but the simplifier ends up with stuff like
+ case (/\a. eq_sel d) of df -> ...(df @Int)...
+and fails to simplify that any further. And it doesn't satisfy
+isPredTy any more.
+
+So for now we simply decline to take superclasses in the quantified
+case. Instead we have a special case in GHC.Tc.Solver.Equality.tryQCsEqCt
+which looks for primitive equalities specially in the quantified
+constraints.
+
+See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.
+-}
+
diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs
index 5dc573b980bb..cfeb78e99544 100644
--- a/compiler/GHC/Tc/Solver/Equality.hs
+++ b/compiler/GHC/Tc/Solver/Equality.hs
@@ -2,15 +2,16 @@
{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Equality(
- solveCanonicalEquality, solveNonCanonicalEquality
+ solveEquality
) where
import GHC.Prelude
+import GHC.Tc.Solver.Irred( solveIrred )
+import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
import GHC.Tc.Solver.Rewrite
import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Types( findFunEqsByTyCon )
import GHC.Tc.Types.Evidence
@@ -59,7 +60,7 @@ import Data.List ( zip4 )
import qualified Data.Semigroup as S
import Data.Bifunctor ( bimap )
-
+import Data.Void( Void )
{- *********************************************************************
* *
@@ -100,44 +101,208 @@ It's as if we treat (->) and (=>) as different type constructors, which
indeed they are!
-}
-solveCanonicalEquality :: EqCt -> TcS (StopOrContinue Ct)
-solveCanonicalEquality (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
- , eq_lhs = lhs, eq_rhs = rhs })
- = solveNonCanonicalEquality ev eq_rel (canEqLHSType lhs) rhs
-
-solveNonCanonicalEquality :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
-solveNonCanonicalEquality ev eq_rel ty1 ty2
- = do { result <- zonk_eq_types ty1 ty2
- ; case result of
- Right ty -> canEqReflexive ev eq_rel ty
- Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2'
- where
- ev' | debugIsOn = setCtEvPredType ev $
- mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'
- | otherwise = ev
+solveEquality :: CtEvidence -> EqRel -> Type -> Type
+ -> SolverStage Void
+solveEquality ev eq_rel ty1 ty2
+ = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2
+ ; let ev' | debugIsOn = setCtEvPredType ev $
+ mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'
+ | otherwise = ev
-- ev': satisfy the precondition of can_eq_nc
- }
-can_eq_nc
- :: Bool -- True => both types are rewritten
- -> CtEvidence
- -> EqRel
- -> Type -> Type -- LHS, after and before type-synonym expansion, resp
- -> Type -> Type -- RHS, after and before type-synonym expansion, resp
- -> TcS (StopOrContinue Ct)
+ ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2'
+
+ ; case mb_canon of {
+
+ -- An IrredCt equality may be insoluble; but maybe not!
+ -- E.g. m a ~R# m b is not canonical, but may be
+ -- solved by a quantified constraint (T15290)
+ -- See Note [Looking up primitive equalities in quantified constraints]
+ Left irred_ct -> do { tryQCsIrredEqCt irred_ct
+ ; solveIrred irred_ct } ;
+
+ Right eq_ct -> do { tryInertEqs eq_ct
+ ; tryFunDeps eq_ct
+ ; tryQCsEqCt eq_ct
+ ; simpleStage (updInertEqs eq_ct)
+ ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } }
+
+updInertEqs :: EqCt -> TcS ()
+updInertEqs eq_ct
+ = do { kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct)) (eqCtFlavourRole eq_ct)
+ ; tc_lvl <- getTcLevel
+ ; updInertCans (addEqToCans tc_lvl eq_ct) }
+
+
+{- *********************************************************************
+* *
+* zonkEqTypes
+* *
+********************************************************************* -}
+
+---------------------------------
+-- | 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
+-- rewriting, 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.
+zonkEqTypes :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage (Pair TcType)
+zonkEqTypes ev eq_rel ty1 ty2
+ = Stage $ do { res <- go ty1 ty2
+ ; case res of
+ Left pair -> continueWith pair
+ Right ty -> canEqReflexive ev eq_rel ty }
+ where
+ go :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
+ 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 (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2)
+ | af1 == af2
+ , eqType w1 w2
+ = do { res_a <- go arg1 arg2
+ ; res_b <- go res1 res2
+ ; return $ combine_rev (FunTy af1 w1) res_b res_a }
+
+ go ty1@(FunTy {}) ty2 = bale_out ty1 ty2
+ go ty1 ty2@(FunTy {}) = bale_out ty1 ty2
+
+ go ty1 ty2
+ | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1
+ , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2
+ = if tc1 == tc2 && tys1 `equalLength` tys2
+ -- Crucial to check for equal-length 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 #13083
+ then tycon tc1 tys1 tys2
+ else bale_out ty1 ty2
+
+ go ty1 ty2
+ | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
+ , Just (ty2a, ty2b) <- tcSplitAppTyNoView_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 rewriting. In particular, no need to zonk kinds. That's why
+ -- we don't use the already-defined 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 already-combined 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)
+
+
+{- *********************************************************************
+* *
+* canonicaliseEquality
+* *
+********************************************************************* -}
+
+canonicaliseEquality
+ :: CtEvidence -> EqRel
+ -> Type -> Type -- LHS and RHS
+ -> SolverStage (Either IrredCt EqCt)
-- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2),
-- without zonking
-- This precondition is needed (only in DEBUG) to satisfy the assertions
-- in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy
-can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2
- = do { traceTcS "can_eq_nc" $
- vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
- ; rdr_env <- getGlobalRdrEnvTcS
- ; fam_insts <- getFamInstEnvs
- ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
+canonicaliseEquality ev eq_rel ty1 ty2
+ = Stage $ do { traceTcS "canonicaliseEquality" $
+ vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ]
+ ; rdr_env <- getGlobalRdrEnvTcS
+ ; fam_insts <- getFamInstEnvs
+ ; can_eq_nc False rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 }
-can_eq_nc'
+can_eq_nc
:: Bool -- True => both input types are rewritten
-> GlobalRdrEnv -- needed to see which newtypes are in scope
-> FamInstEnvs -- needed to unwrap data instances
@@ -145,59 +310,59 @@ can_eq_nc'
-> EqRel
-> Type -> Type -- LHS, after and before type-synonym expansion, resp
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
-can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
+can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
| tc1 == tc2
= canEqReflexive ev eq_rel ty1
-- Expand synonyms first; see Note [Type synonyms and canonicalization]
-can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
- | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
- | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2
+can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+ | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
+ | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs 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 rewritten because the zonk_eq_types check in canEqNC takes
-- care of the non-rewritten case.
-can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
+can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _
| ty1 `tcEqType` ty2
= canEqReflexive ev ReprEq ty1
-- When working with ReprEq, unwrap newtypes.
-- See Note [Unwrap newtypes first]
-- This must be above the TyVarTy case, in order to guarantee (TyEq:N)
-can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
| ReprEq <- eq_rel
, Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
- = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
+ = can_eq_newtype_nc rdr_env envs ev NotSwapped ty1 stuff1 ty2 ps_ty2
| ReprEq <- eq_rel
, Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
- = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1
+ = can_eq_newtype_nc rdr_env envs ev IsSwapped ty2 stuff2 ty1 ps_ty1
-- Then, get rid of casts
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
+can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
| isNothing (canEqLHS_maybe ty2) -- See (EIK3) in Note [Equalities with incompatible kinds]
- = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
+ = canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
+can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
| isNothing (canEqLHS_maybe ty1) -- See (EIK3) in Note [Equalities with incompatible kinds]
- = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
+ = canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
----------------------
-- Otherwise try to decompose
----------------------
-- Literals
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
+can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
| l1 == l2
= do { setEvBindIfWanted ev IsCoherent (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
; stopWith ev "Equal LitTy" }
-- Decompose FunTy: (s -> t) and (c => t)
-- NB: don't decompose (Int -> blah) ~ (Show a => blah)
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
+can_eq_nc _rewritten _rdr_env _envs ev eq_rel
(FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1
(FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2
| af1 == af2 -- See Note [Decomposing FunTy]
@@ -205,7 +370,7 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-- Decompose type constructor applications
-- NB: we have expanded type synonyms already
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
+can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
| Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
, Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
-- tcSplitTyConApp_maybe: we want to catch e.g. Maybe Int ~ (Int -> Int)
@@ -222,7 +387,7 @@ can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
, rewritten || both_generative
= canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
+can_eq_nc _rewritten _rdr_env _envs ev eq_rel
s1@(ForAllTy (Bndr _ vis1) _) _
s2@(ForAllTy (Bndr _ vis2) _) _
| vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality]
@@ -232,7 +397,7 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
-- NB: Only decompose AppTy for nominal equality.
-- See Note [Decomposing AppTy equalities]
-can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
+can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _
| Just (t1, s1) <- tcSplitAppTy_maybe ty1
, Just (t2, s2) <- tcSplitAppTy_maybe ty2
= can_eq_app ev t1 s1 t2 s2
@@ -242,13 +407,13 @@ can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
-------------------
-- No similarity in type structure detected. Rewrite and try again.
-can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
+can_eq_nc False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
= -- Rewrite the two types and try again
do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2)
- ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+ ; can_eq_nc True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
----------------------------
-- Look for a canonical LHS.
@@ -258,7 +423,8 @@ can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
-- NB: pattern match on rewritten=True: we want only rewritten types sent to canEqLHS
-- This means we've rewritten any variables and reduced any type family redexes
-- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+
+can_eq_nc True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
| Just can_eq_lhs1 <- canEqLHS_maybe ty1
= do { traceTcS "can_eq1" (ppr ty1 $$ ppr ty2)
; canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 }
@@ -273,18 +439,18 @@ can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-- _both_ sides of the equality are AppTy-like... but if one side is
-- AppTy-like and the other isn't (and it also isn't a variable or
-- saturated type family application, both of which are handled by
- -- can_eq_nc'), we're in a failure mode and can just fall through.
+ -- can_eq_nc), we're in a failure mode and can just fall through.
----------------------------
-- Fall-through. Give up.
----------------------------
-- We've rewritten 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' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
+can_eq_nc True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
+ = do { traceTcS "can_eq_nc catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
; case eq_rel of -- See Note [Unsolved equalities]
- ReprEq -> solveIrredEquality ReprEqReason ev
- NomEq -> solveIrredEquality ShapeMismatchReason ev }
+ ReprEq -> finishCanWithIrred ReprEqReason ev
+ NomEq -> finishCanWithIrred ShapeMismatchReason ev }
-- No need to call canEqSoftFailure/canEqHardFailure because they
-- rewrite, and the types involved here are already rewritten
@@ -301,7 +467,7 @@ Missing this point is what caused #15431
---------------------------------
can_eq_nc_forall :: CtEvidence -> EqRel
-> Type -> Type -- LHS and RHS
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- (forall as. phi1) ~ (forall bs. phi2)
-- Check for length match of as, bs
-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
@@ -377,139 +543,6 @@ can_eq_nc_forall ev eq_rel s1 s2
= do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2
; return (co, unitBag (mkNonCanonical wanted)) }
----------------------------------
--- | 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
--- rewriting, 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 (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2)
- | af1 == af2
- , eqType w1 w2
- = do { res_a <- go arg1 arg2
- ; res_b <- go res1 res2
- ; return $ combine_rev (FunTy af1 w1) res_b res_a }
-
- go ty1@(FunTy {}) ty2 = bale_out ty1 ty2
- go ty1 ty2@(FunTy {}) = bale_out ty1 ty2
-
- go ty1 ty2
- | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1
- , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2
- = if tc1 == tc2 && tys1 `equalLength` tys2
- -- Crucial to check for equal-length 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 #13083
- then tycon tc1 tys1 tys2
- else bale_out ty1 ty2
-
- go ty1 ty2
- | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
- , Just (ty2a, ty2b) <- tcSplitAppTyNoView_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 rewriting. In particular, no need to zonk kinds. That's why
- -- we don't use the already-defined 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 already-combined 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 [Unwrap newtypes first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -619,14 +652,15 @@ though, because we check our depth in `can_eq_newtype_nc`.
------------------------
-- | We're able to unwrap a newtype. Update the bits accordingly.
-can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2
+can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs
+ -> 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, co1), ty1') ty2 ps_ty2
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
+can_eq_newtype_nc rdr_env envs ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
= do { traceTcS "can_eq_newtype_nc" $
vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
@@ -645,7 +679,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped
redn1 (mkReflRedn Representational ps_ty2)
- ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
+ ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
---------
-- ^ Decompose a type application.
@@ -654,7 +688,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2
-> Xi -> Xi -- s1 t1
-> Xi -> Xi -- s2 t2
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- AppTys only decompose for nominal equality, so this case just leads
-- to an irreducible constraint; see typecheck/should_compile/T10494
@@ -692,7 +726,7 @@ can_eq_app ev s1 t1 s2 t2
; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
, evCoercion co_t )
; emitWorkNC [evar_t]
- ; solveNonCanonicalEquality evar_s NomEq s1 s2 }
+ ; startAgainWith (mkNonCanonical evar_s) }
where
loc = ctEvLoc ev
@@ -708,20 +742,21 @@ can_eq_app ev s1 t1 s2 t2
-- | Break apart an equality over a casted type
-- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag)
canEqCast :: Bool -- are both types rewritten?
+ -> GlobalRdrEnv -> FamInstEnvs
-> CtEvidence
-> EqRel
-> SwapFlag
-> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1
-> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty
- -> TcS (StopOrContinue Ct)
-canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
+canEqCast rewritten rdr_env envs 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 emptyRewriterSet ev swapped
(mkGReflLeftRedn role ty1 co1)
(mkReflRedn role ps_ty2)
- ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
+ ; can_eq_nc rewritten rdr_env envs new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
where
role = eqRelRole eq_rel
@@ -730,14 +765,14 @@ canTyConApp :: CtEvidence -> EqRel
-> Bool -- Both TyCons are generative
-> TyCon -> [TcType]
-> TyCon -> [TcType]
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- See Note [Decomposing TyConApp equalities]
-- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family
-- But they can be data families.
canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2
| tc1 == tc2
, tys1 `equalLength` tys2
- = do { inerts <- getTcSInerts
+ = do { inerts <- getInertSet
; if can_decompose inerts
then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
else canEqSoftFailure ev eq_rel ty1 ty2 }
@@ -745,7 +780,7 @@ canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2
-- See Note [Skolem abstract data] in GHC.Core.Tycon
| tyConSkolem tc1 || tyConSkolem tc2
= do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
- ; solveIrredEquality AbstractTyConReason ev }
+ ; finishCanWithIrred AbstractTyConReason ev }
| otherwise -- Different TyCons
= if both_generative -- See (TC2) and (TC3) in
@@ -1011,7 +1046,7 @@ There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete:
which is unsatisfiable. Unwrapping, though, leads to a solution.
Conclusion: always unwrap newtypes before attempting to decompose
- them. This is done in can_eq_nc'. Of course, we can't unwrap if the data
+ them. This is done in can_eq_nc. Of course, we can't unwrap if the data
constructor isn't in scope. See Note [Unwrap newtypes first].
* Incompleteness example (EX2): available Givens
@@ -1026,7 +1061,7 @@ There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete:
out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted
from the Given. This is somewhat similar to the question of overlapping
Givens for class constraints: see Note [Instance and Given overlap] in
- GHC.Tc.Solver.Interact.
+ GHC.Tc.Solver.Dict.
Conclusion: don't decompose [W] N s ~R N t, if there are any Given
equalities that could later solve it.
@@ -1187,7 +1222,7 @@ and all will be well. See also Note [Unwrap newtypes first].
Bottom line:
* Always decompose AppTy at nominal role: can_eq_app
* Never decompose AppTy at representational role (neither Given nor Wanted):
- the lack of an equation in can_eq_nc'
+ the lack of an equation in can_eq_nc
Extra points
{1} Decomposing a Given AppTy over a representational role is simply
@@ -1213,7 +1248,7 @@ Extra points
canDecomposableTyConAppOK :: CtEvidence -> EqRel
-> TyCon -> [TcType] -> [TcType]
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue a)
-- Precondition: tys1 and tys2 are the same finite length, hence "OK"
canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
= assert (tys1 `equalLength` tys2) $
@@ -1270,7 +1305,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag
-> (Type,Type,Type) -- (multiplicity,arg,res)
-> (Type,Type,Type) -- (multiplicity,arg,res)
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue a)
canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)
= do { traceTcS "canDecomposableFunTy"
(ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
@@ -1301,8 +1336,8 @@ canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)
-- | Call canEqSoftFailure when canonicalizing an equality fails, but if the
-- equality is representational, there is some hope for the future.
-canEqSoftFailure :: CtEvidence -> EqRel
- -> TcType -> TcType -> TcS (StopOrContinue Ct)
+canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType
+ -> TcS (StopOrContinue (Either IrredCt a))
canEqSoftFailure ev NomEq ty1 ty2
= canEqHardFailure ev ty1 ty2
canEqSoftFailure ev ReprEq ty1 ty2
@@ -1314,18 +1349,18 @@ canEqSoftFailure ev ReprEq ty1 ty2
; traceTcS "canEqSoftFailure with ReprEq" $
vcat [ ppr ev, ppr redn1, ppr redn2 ]
; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
- ; continueWith (mkIrredCt ReprEqReason new_ev) }
+ ; finishCanWithIrred ReprEqReason new_ev }
-- | Call when canonicalizing an equality fails with utterly no hope.
-canEqHardFailure :: CtEvidence
- -> TcType -> TcType -> TcS (StopOrContinue Ct)
+canEqHardFailure :: CtEvidence -> TcType -> TcType
+ -> TcS (StopOrContinue (Either IrredCt a))
-- See Note [Make sure that insolubles are fully rewritten]
canEqHardFailure ev ty1 ty2
= do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
; (redn1, rewriters1) <- rewriteForErrors ev ty1
; (redn2, rewriters2) <- rewriteForErrors ev ty2
; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
- ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
+ ; finishCanWithIrred ShapeMismatchReason new_ev }
{-
Note [Canonicalising type applications]
@@ -1445,7 +1480,7 @@ canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs
-> CanEqLHS -- lhs (or, if swapped, rhs)
-> TcType -- lhs: pretty lhs, already rewritten
-> TcType -> TcType -- rhs: already rewritten
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
| k1 `tcEqType` k2
= canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
@@ -1461,10 +1496,11 @@ canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
{-
Note [Kind Equality Orientation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in practice it does not.
-See Note [Fundeps with instances, and equality orientation] where this is discussed at length.
-As a rule of thumb: we keep the newest unification variables on the left of the equality.
-See also Note [Improvement orientation] in GHC.Tc.Solver.Interact.
+While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in
+practice it does not. See Note [Fundeps with instances, and equality
+orientation] where this is discussed at length. As a rule of thumb: we keep
+the newest unification variables on the left of the equality. See also
+Note [Improvement orientation].
In particular, `canEqCanLHSHetero` produces the following constraint equalities
@@ -1493,13 +1529,13 @@ canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
-> TcKind -- ki1
-> TcType -> TcType -- xi2
-> TcKind -- ki2
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
-- See Note [Equalities with incompatible kinds]
-- See Note [Kind Equality Orientation]
-- NB: preserve left-to-right orientation!! See wrinkle (W2) in
--- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Interact
+-- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict
-- NotSwapped:
-- ev :: (lhs1:ki1) ~r# (xi2:ki2)
-- kind_co :: k11 ~# ki2 -- Same orientiation as ev
@@ -1556,7 +1592,7 @@ canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs
-> EqRel -> SwapFlag
-> CanEqLHS -> TcType -- lhs, pretty lhs
-> TcType -> TcType -- rhs, pretty rhs
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- Guaranteed that typeKind lhs == typeKind rhs
canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
| (xi2', mco) <- split_cast_ty xi2
@@ -1580,7 +1616,7 @@ canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco)
-> CanEqLHS -- rhs
-> TcType -- pretty rhs
-> MCoercion -- :: kind(rhs) ~N kind(lhs)
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
| lhs1 `eqCanEqLHS` lhs2
-- It must be the case that mco is reflexive
@@ -1705,16 +1741,16 @@ If we have a TyFamLHS on both sides, we choose how to orient it.
-- want to rewrite the LHS to (as per e.g. swapOverTyVars)
canEqCanLHSFinish, canEqCanLHSFinish_try_unification,
canEqCanLHSFinish_no_unification
- :: CtEvidence
+ :: CtEvidence -- (lhs ~ rhs) or if swapped (rhs ~ lhs)
-> EqRel -> SwapFlag
- -> CanEqLHS -- lhs (or, if swapped, rhs)
- -> TcType -- rhs (or, if swapped, lhs)
- -> TcS (StopOrContinue Ct)
+ -> CanEqLHS -- lhs
+ -> TcType -- rhs
+ -> TcS (StopOrContinue (Either IrredCt EqCt))
-- RHS is fully rewritten, but with type synonyms
-- preserved as much as possible
-- Guaranteed preconditions that
-- (TyEq:K) handled in canEqCanLHSHomo
- -- (TyEq:N) checked in can_eq_nc'
+ -- (TyEq:N) checked in can_eq_nc
-- (TyEq:TV) handled in canEqCanLHS2
---------------------------
@@ -1815,9 +1851,9 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
evCoercion (mkNomReflCo final_rhs)
-- Kick out any constraints that can now be rewritten
- ; n_kicked <- kickOutAfterUnification [tv]
+ ; kickOutAfterUnification [tv]
- ; return (Stop new_ev (text "Solved by unification" <+> pprKicked n_kicked)) }}}}
+ ; return (Stop new_ev (text "Solved by unification")) }}}}
-- Otherwise unification is off the table
| otherwise
@@ -1868,49 +1904,59 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-- * new_ev has reductionReducedType on the RHS
-- * eq_rhs is set to reductionReducedType
-- See Note [Forgetful synonyms in checkTyConApp] in GHC.Tc.Utils.Unify
- ; interactEq (EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
- , eq_lhs = lhs
- , eq_rhs = reductionReducedType rhs_redn }) } }
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs
+ , eq_rhs = reductionReducedType rhs_redn } } }
----------------------
swapAndFinish :: CtEvidence -> EqRel -> SwapFlag
-> TcType -> CanEqLHS -- ty ~ F tys
- -> TcS (StopOrContinue Ct)
+ -> TcS (StopOrContinue (Either unused EqCt))
-- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys'
-- mentions alpha, it would not be a canonical constraint as-is.
-- We want to flip it to (F tys ~ a), whereupon it is canonical
swapAndFinish ev eq_rel swapped lhs_ty can_rhs
- = do { new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped)
+ = do { let role = eqRelRole eq_rel
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped)
(mkReflRedn role (canEqLHSType can_rhs))
(mkReflRedn role lhs_ty)
- ; interactEq (EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
- , eq_lhs = can_rhs, eq_rhs = lhs_ty }) }
- where
- role = eqRelRole eq_rel
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = can_rhs, eq_rhs = lhs_ty } }
----------------------
-tryIrredInstead :: CheckTyEqResult -> CtEvidence -> EqRel -> SwapFlag
- -> CanEqLHS -> TcType -> TcS (StopOrContinue Ct)
+tryIrredInstead :: CheckTyEqResult -> CtEvidence
+ -> EqRel -> SwapFlag -> CanEqLHS -> TcType
+ -> TcS (StopOrContinue (Either IrredCt unused))
-- We have a non-canonical equality
-- We still swap it if 'swapped' says so, so that it is oriented
--- in the direction that the error message reporting machinery
+-- in the direction that the error-reporting machinery
-- expects it; e.g. (m ~ t m) rather than (t m ~ m)
-- This is not very important, and only affects error reporting.
tryIrredInstead reason ev eq_rel swapped lhs rhs
= do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs)
+ ; let role = eqRelRole eq_rel
; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
(mkReflRedn role (canEqLHSType lhs))
(mkReflRedn role rhs)
- ; solveIrredEquality (NonCanonicalReason reason) new_ev }
- where
- role = eqRelRole eq_rel
+ ; finishCanWithIrred (NonCanonicalReason reason) new_ev }
+
+finishCanWithIrred :: CtIrredReason -> CtEvidence
+ -> TcS (StopOrContinue (Either IrredCt a))
+finishCanWithIrred reason ev
+ = do { -- Abort fast if we have any insoluble Wanted constraints,
+ -- and the TcS abort-if-insoluble flag is on.
+ when (isInsolubleReason reason) tryEarlyAbortTcS
+
+ ; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } }
-----------------------
-- | Solve a reflexive equality constraint
canEqReflexive :: CtEvidence -- ty ~ ty
-> EqRel
-> TcType -- ty
- -> TcS (StopOrContinue Ct) -- always Stop
+ -> TcS (StopOrContinue a) -- always Stop
canEqReflexive ev eq_rel ty
= do { setEvBindIfWanted ev IsCoherent $
evCoercion (mkReflCo (eqRelRole eq_rel) ty)
@@ -2001,7 +2047,7 @@ Wrinkles:
And this is an improvement regardless: because tyvars can, generally,
unify with casted types, there's no reason to go through the work of
stripping off the cast when the cast appears opposite a tyvar. This is
- implemented in the cast case of can_eq_nc'.
+ implemented in the cast case of can_eq_nc.
Historical note:
@@ -2450,7 +2496,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
{-
**********************************************************************
* *
- interactEq
+ tryInertEqs
* *
**********************************************************************
@@ -2490,10 +2536,10 @@ But it's not so simple:
call to strictly_more_visible.
-}
-interactEq :: EqCt -> TcS (StopOrContinue Ct)
-interactEq work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
-
- = do { inerts <- getInertCans
+tryInertEqs :: EqCt -> SolverStage ()
+tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel })
+ = Stage $
+ do { inerts <- getInertCans
; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item
-> do { setEvBindIfWanted ev IsCoherent $
evCoercion (maybeSymCo swapped $
@@ -2503,14 +2549,7 @@ interactEq work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
; stopWith ev "Solved from inert" }
| otherwise
- -> case lhs of
- TyVarLHS {} -> finishEqCt work_item
- TyFamLHS tc args -> do { imp1 <- improveLocalFunEqs inerts tc args work_item
- ; imp2 <- improveTopFunEqs tc args work_item
- ; if (imp1 || imp2)
- then startAgainWith (mkNonCanonical ev)
- else finishEqCt work_item } }
-
+ -> continueWith () }
inertsCanDischarge :: InertCans -> EqCt
-> Maybe ( CtEvidence -- The evidence for the inert
@@ -2630,6 +2669,7 @@ make the solver iterate more often. (We don't need to iterate when unifying
at the ambient level because of the kick-out mechanism.)
-}
+
{-********************************************************************
* *
Final wrap-up for equalities
@@ -2645,45 +2685,43 @@ kind is not Constraint, such as (forall a. F a ~# b)
See
* Note [Evidence for quantified constraints] in GHC.Core.Predicate
* Note [Equality superclasses in quantified constraints]
- in GHC.Tc.Solver.Canonical
+ in GHC.Tc.Solver.Dict
-}
--------------------
-solveIrredEquality :: CtIrredReason -> CtEvidence -> TcS (StopOrContinue Ct)
-solveIrredEquality reason ev
+tryQCsIrredEqCt :: IrredCt -> SolverStage ()
+tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev })
| EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev)
- = final_qci_check (mkIrredCt reason ev) eq_rel t1 t2
- -- If the final_qci_check fails, we'll do continueWith on an IrredCt
- -- That in turn will go down the Irred pipeline, so which deals with
- -- the case where we have [G] Coercible (m a) (m b), and [W] m a ~R# m b
- -- When we de-pipeline Irreds we may have to adjust here
-
- | otherwise -- All the calls come from in this module, where we deal
- -- only with equalities, so ctEvPred ev) must be an equality.
- -- Indeed, we could pass eq_rel, t1, t2 as arguments, to avoid
- -- this can't happen case, but it's not a hot path, and this is
- -- simple and robust
+ = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2
+
+ | otherwise -- All the calls come from in this module, where we deal only with
+ -- equalities, so ctEvPred ev) must be an equality. Indeed, we could
+ -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case,
+ -- but it's not a hot path, and this is simple and robust
= pprPanic "solveIrredEquality" (ppr ev)
--------------------
-finishEqCt :: EqCt -> TcS (StopOrContinue Ct)
-finishEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel })
- = final_qci_check (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs
+tryQCsEqCt :: EqCt -> SolverStage ()
+tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel })
+ = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs
--------------------
-final_qci_check :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
+lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage ()
-- The "final QCI check" checks to see if we have
-- [W] t1 ~# t2
-- and a Given quantified contraint like (forall a b. blah => a ~ b)
-- Why? See Note [Looking up primitive equalities in quantified constraints]
-final_qci_check work_ct eq_rel lhs rhs
- = do { ev_binds_var <- getTcEvBindsVar
+-- See also GHC.Tc.Solver.Dict
+-- Note [Equality superclasses in quantified constraints]
+lookup_eq_in_qcis work_ct eq_rel lhs rhs
+ = Stage $
+ do { ev_binds_var <- getTcEvBindsVar
; ics <- getInertCans
; if isWanted ev -- Never look up Givens in quantified constraints
&& not (null (inert_insts ics)) -- Shortcut common case
&& not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications]
then try_for_qci
- else continueWith work_ct }
+ else continueWith () }
where
ev = ctEvidence work_ct
loc = ctEvLoc ev
@@ -2692,27 +2730,27 @@ final_qci_check work_ct eq_rel lhs rhs
try_for_qci -- First try looking for (lhs ~ rhs)
| Just (cls, tys) <- boxEqPred eq_rel lhs rhs
= do { res <- matchLocalInst (mkClassPred cls tys) loc
- ; traceTcS "final_qci_check:1" (ppr (mkClassPred cls tys))
+ ; traceTcS "lookup_irred_in_qcis:1" (ppr (mkClassPred cls tys))
; case res of
OneInst { cir_mk_ev = mk_ev }
-> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
_ -> try_swapping }
| otherwise
- = continueWith work_ct
+ = continueWith ()
try_swapping -- Now try looking for (rhs ~ lhs) (see #23333)
| Just (cls, tys) <- boxEqPred eq_rel rhs lhs
= do { res <- matchLocalInst (mkClassPred cls tys) loc
- ; traceTcS "final_qci_check:2" (ppr (mkClassPred cls tys))
+ ; traceTcS "lookup_irred_in_qcis:2" (ppr (mkClassPred cls tys))
; case res of
OneInst { cir_mk_ev = mk_ev }
-> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped
(mkReflRedn role rhs) (mkReflRedn role lhs)
; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) }
- _ -> do { traceTcS "final_qci_check:3" (ppr work_ct)
- ; continueWith work_ct }}
+ _ -> do { traceTcS "lookup_irred_in_qcis:3" (ppr work_ct)
+ ; continueWith () }}
| otherwise
- = continueWith work_ct
+ = continueWith ()
mk_eq_ev cls tys mk_ev evs
| sc_id : rest <- classSCSelIds cls -- Just one superclass for this
@@ -2840,7 +2878,7 @@ tryFamFamInjectivity ev eq_rel fun_tc1 fun_args1 fun_tc2 fun_args2 mco
| fun_tc1 /= fun_tc2
= return False -- If the families don't match, stop.
| isGiven ev
- = return False -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact
+ = return False -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Dict
-- So this is a [W] (F tys1 ~N# F tys2)
@@ -2876,6 +2914,19 @@ tryFamFamInjectivity ev eq_rel fun_tc1 fun_args1 fun_tc2 fun_args2 mco
| otherwise -- ordinary, non-injective type family
= return False
+--------------------
+tryFunDeps :: EqCt -> SolverStage ()
+tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev })
+ = Stage $
+ case lhs of
+ TyFamLHS tc args -> do { inerts <- getInertCans
+ ; imp1 <- improveLocalFunEqs inerts tc args work_item
+ ; imp2 <- improveTopFunEqs tc args work_item
+ ; if (imp1 || imp2)
+ then startAgainWith (mkNonCanonical ev)
+ else continueWith () }
+ TyVarLHS {} -> continueWith ()
+
--------------------
improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool
-- See Note [FunDep and implicit parameter reactions]
@@ -3096,7 +3147,7 @@ We generate these Wanteds in three places, depending on how we notice the
injectivity.
1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
-described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical.
+described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality
2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
constraints rewrites the other, as they have different LHSs. This is done
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index ab3f8c96380f..28b1e2871767 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -17,19 +17,26 @@ module GHC.Tc.Solver.InertSet (
-- * The inert set
InertSet(..),
InertCans(..),
- InertEqs,
emptyInert,
- addInertItem,
noMatchableGivenDicts,
- noGivenNewtypeReprEqs,
+ noGivenNewtypeReprEqs, updGivenEqs,
mightEqualLater,
prohibitedSuperClassSolve,
-- * Inert equalities
+ InertEqs,
foldTyEqs, delEq, findEq,
partitionInertEqs, partitionFunEqs,
- foldFunEqs,
+ foldFunEqs, addEqToCans,
+
+ -- * Inert Dicts
+ updDicts, delDict, addDict, filterDicts, partitionDicts,
+ addSolvedDict,
+
+ -- * Inert Irreds
+ InertIrreds, delIrred, addIrreds, addIrred, foldIrreds,
+ findMatchingIrreds, updIrreds, addIrredToCans,
-- * Kick-out
KickOutSpec(..), kickOutRewritableLHS,
@@ -38,7 +45,10 @@ module GHC.Tc.Solver.InertSet (
CycleBreakerVarStack,
pushCycleBreakerVarStack,
addCycleBreakerBindings,
- forAllCycleBreakerBindings_
+ forAllCycleBreakerBindings_,
+
+ -- * Solving one from another
+ InteractResult(..), solveOneFromTheOther
) where
@@ -52,6 +62,7 @@ import GHC.Tc.Utils.TcType
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
+import GHC.Types.Basic( SwapFlag(..) )
import GHC.Core.Reduction
import GHC.Core.Predicate
@@ -59,18 +70,20 @@ import GHC.Core.TyCo.FVs
import qualified GHC.Core.TyCo.Rep as Rep
import GHC.Core.Class( Class )
import GHC.Core.TyCon
+import GHC.Core.Class( classTyCon )
import GHC.Core.Unify
-import GHC.Data.Bag
-
import GHC.Utils.Misc ( partitionWith )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Data.Maybe
+import GHC.Data.Bag
import Data.List.NonEmpty ( NonEmpty(..), (<|) )
import qualified Data.List.NonEmpty as NE
-import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe
+import Data.Function ( on )
+
import Control.Monad ( forM_ )
{-
@@ -228,7 +241,7 @@ extendWorkListCt ct wl
-> extendWorkListEq rewriters ct wl
ClassPred cls _ -- See Note [Prioritise class equalities]
- | isEqPredClass cls
+ | isEqualityClass cls
-> extendWorkListEq rewriters ct wl
_ -> extendWorkListNonEq ct wl
@@ -284,7 +297,7 @@ type CycleBreakerVarStack = NonEmpty (Bag (TcTyVar, TcType))
-- first element in the stack corresponds to current implication;
-- later elements correspond to outer implications
-- used to undo the cycle-breaking needed to handle
- -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical
+ -- Note [Type equality cycles] in GHC.Tc.Solver.Equality
-- Why store the outer implications? For the use in mightEqualLater (only)
--
-- Why NonEmpty? So there is always a top element to add to
@@ -306,8 +319,9 @@ data InertSet
-- (We have no way of "kicking out" from the cache, so putting
-- wanteds here means we can end up solving a Wanted with itself. Bad)
- , inert_solved_dicts :: DictMap CtEvidence
- -- All Wanteds, of form ev :: C t1 .. tn
+ , inert_solved_dicts :: DictMap CtEvidence
+ -- All Wanteds, of form (C t1 .. tn)
+ -- Always a dictionary solved by an instance decl; never an implict parameter
-- See Note [Solved dictionaries]
-- and Note [Do not add superclasses of solved dictionaries]
}
@@ -330,7 +344,7 @@ emptyInertCans
, inert_dicts = emptyDictMap
, inert_safehask = emptyDictMap
, inert_insts = []
- , inert_irreds = emptyCts }
+ , inert_irreds = emptyBag }
emptyInert :: InertSet
emptyInert
@@ -406,7 +420,7 @@ In implementation terms
conditional on the kind of instance
- It is only called when applying an instance decl,
- in GHC.Tc.Solver.Interact.doTopReactDict
+ in GHC.Tc.Solver.Dict.tryInstances
- ClsInst.InstanceWhat says what kind of instance was
used to solve the constraint. In particular
@@ -587,7 +601,7 @@ InertCans tracks
-- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).
We update inert_given_eq_lvl whenever we add a Given to the
-inert set, in updateGivenEqs.
+inert set, in updGivenEqs.
Then a unification variable alpha[n] is untouchable iff
n < inert_given_eq_lvl
@@ -613,7 +627,7 @@ should update inert_given_eq_lvl?
same example again, but this time we have /not/ yet unified beta:
forall[2] beta[1] => ...blah...
- Because beta might turn into an equality, updateGivenEqs conservatively
+ Because beta might turn into an equality, updGivenEqs conservatively
treats it as a potential equality, and updates inert_give_eq_lvl
* What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?
@@ -623,7 +637,7 @@ should update inert_given_eq_lvl?
implication. Such equalities need not make alpha untouchable. (Test
case typecheck/should_compile/LocalGivenEqs has a real-life
motivating example, with some detailed commentary.)
- Hence the 'mentionsOuterVar' test in updateGivenEqs.
+ Hence the 'mentionsOuterVar' test in updGivenEqs.
However, solely to support better error messages
(see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track
@@ -813,7 +827,7 @@ places are not used in matching instances or in decomposing equalities.
There is one exception to the claim that non-rewritable parts of the tree do
not affect the solver: we sometimes do an occurs-check to decide e.g. how to
orient an equality. (See the comments on
-GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a
+GHC.Tc.Solver.Equality.canEqTyVarFunEq.) Accordingly, the presence of a
variable in a kind or coercion just might influence the solver. Here is an
example:
@@ -1126,14 +1140,14 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more
-- wrt inert_eqs
-- Can include both [G] and [W]
- , inert_dicts :: DictMap Ct
+ , inert_dicts :: DictMap DictCt
-- Dictionaries only
-- All fully rewritten (modulo flavour constraints)
-- wrt inert_eqs
, inert_insts :: [QCInst]
- , inert_safehask :: DictMap Ct
+ , inert_safehask :: DictMap DictCt
-- 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
@@ -1142,7 +1156,7 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more
-- ^ See Note [Safe Haskell Overlapping Instances Implementation]
-- in GHC.Tc.Solver
- , inert_irreds :: Cts
+ , inert_irreds :: InertIrreds
-- 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])
@@ -1163,6 +1177,7 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more
type InertEqs = DTyVarEnv EqualCtList
type InertFunEqs = FunEqMap EqualCtList
+type InertIrreds = Bag IrredCt
instance Outputable InertCans where
ppr (IC { inert_eqs = eqs
@@ -1185,7 +1200,7 @@ instance Outputable InertCans where
text "Dictionaries =" <+> pprBag (dictsToBag dicts)
, ppUnless (isEmptyTcAppMap safehask) $
text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask)
- , ppUnless (isEmptyCts irreds) $
+ , ppUnless (isEmptyBag irreds) $
text "Irreds =" <+> pprBag irreds
, ppUnless (null insts) $
text "Given instances =" <+> vcat (map ppr insts)
@@ -1203,6 +1218,14 @@ instance Outputable InertCans where
emptyTyEqs :: InertEqs
emptyTyEqs = emptyDVarEnv
+addEqToCans :: TcLevel -> EqCt -> InertCans -> InertCans
+addEqToCans tc_lvl eq_ct@(EqCt { eq_lhs = lhs })
+ ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })
+ = updGivenEqs tc_lvl (CEqCan eq_ct) $
+ case lhs of
+ TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct }
+ TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv eq_ct }
+
addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs
addTyEq old_eqs tv ct
= extendDVarEnv_C add_eq old_eqs tv [ct]
@@ -1216,8 +1239,8 @@ foldTyEqs k eqs z
findTyEqs :: InertCans -> TyVar -> [EqCt]
findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv)
-delEq :: InertCans -> EqCt -> InertCans
-delEq ic (EqCt { eq_lhs = lhs, eq_rhs = rhs }) = case lhs of
+delEq :: EqCt -> InertCans -> InertCans
+delEq (EqCt { eq_lhs = lhs, eq_rhs = rhs }) ic = case lhs of
TyVarLHS tv
-> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }
TyFamLHS tf args
@@ -1240,7 +1263,7 @@ partition_eqs_container
:: forall container
. container -- empty container
-> (forall b. (EqCt -> b -> b) -> container -> b -> b) -- folder
- -> (container -> EqCt -> container) -- extender
+ -> (EqCt -> container -> container) -- extender
-> (EqCt -> Bool)
-> container
-> ([EqCt], container)
@@ -1250,17 +1273,17 @@ partition_eqs_container empty_container fold_container extend_container pred ori
folder :: EqCt -> ([EqCt], container) -> ([EqCt], container)
folder eq_ct (acc_true, acc_false)
| pred eq_ct = (eq_ct : acc_true, acc_false)
- | otherwise = (acc_true, extend_container acc_false eq_ct)
+ | otherwise = (acc_true, extend_container eq_ct acc_false)
partitionInertEqs :: (EqCt -> Bool) -- EqCt will always have a TyVarLHS
-> InertEqs
-> ([EqCt], InertEqs)
-partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs extendInertEqs
+partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs
-extendInertEqs :: InertEqs -> EqCt -> InertEqs
+addInertEqs :: EqCt -> InertEqs -> InertEqs
-- Precondition: CanEqLHS is a TyVarLHS
-extendInertEqs eqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) = addTyEq eqs tv eq_ct
-extendInertEqs _ other = pprPanic "extendInertEqs" (ppr other)
+addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct
+addInertEqs other _ = pprPanic "extendInertEqs" (ppr other)
------------------------
@@ -1277,48 +1300,139 @@ foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z
partitionFunEqs :: (EqCt -> Bool) -- EqCt will have a TyFamLHS
-> InertFunEqs
-> ([EqCt], InertFunEqs)
-partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs extendFunEqs
+partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs addFunEqs
-extendFunEqs :: InertFunEqs -> EqCt -> InertFunEqs
+addFunEqs :: EqCt -> InertFunEqs -> InertFunEqs
-- Precondition: EqCt is a TyFamLHS
-extendFunEqs fun_eqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args })
+addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs
= addCanFunEq fun_eqs tc args eq_ct
-extendFunEqs _ other = pprPanic "extendFunEqs" (ppr other)
+addFunEqs other _ = pprPanic "extendFunEqs" (ppr other)
+
+
{- *********************************************************************
* *
- Adding to and removing from the inert set
+ Inert Dicts
* *
+********************************************************************* -}
+
+updDicts :: (DictMap DictCt -> DictMap DictCt) -> InertCans -> InertCans
+updDicts upd ics = ics { inert_dicts = upd (inert_dicts ics) }
+
+delDict :: DictCt -> DictMap a -> DictMap a
+delDict (DictCt { di_cls = cls, di_tys = tys }) m
+ = delTcApp m (classTyCon cls) tys
+
+addDict :: DictCt -> DictMap DictCt -> DictMap DictCt
+addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm
+ = insertTcApp dm (classTyCon cls) tys item
+
+addSolvedDict :: Class -> [Type] -> CtEvidence
+ -> DictMap CtEvidence -> DictMap CtEvidence
+addSolvedDict cls tys ev dm
+ = insertTcApp dm (classTyCon cls) tys ev
+
+filterDicts :: (DictCt -> Bool) -> DictMap DictCt -> DictMap DictCt
+filterDicts f m = filterTcAppMap f m
+
+partitionDicts :: (DictCt -> Bool) -> DictMap DictCt -> (Bag DictCt, DictMap DictCt)
+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)
+ where
+ k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes)
+ | otherwise = (yeses, addDict ct noes)
+
+
+{- *********************************************************************
+* *
+ Inert Irreds
* *
********************************************************************* -}
-addInertItem :: TcLevel -> InertCans -> Ct -> InertCans
-addInertItem tc_lvl
- ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })
- item@(CEqCan eq_ct)
- = updateGivenEqs tc_lvl item $
- case eq_lhs eq_ct of
- TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct }
- TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv eq_ct }
+addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans
+addIrredToCans tc_lvl irred ics
+ = updGivenEqs tc_lvl (CIrredCan irred) $
+ updIrreds (addIrred irred) ics
+
+addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds
+addIrreds extras irreds
+ | null extras = irreds
+ | otherwise = irreds `unionBags` listToBag extras
-addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})
- = updateGivenEqs tc_lvl item $ -- An Irred might turn out to be an
- -- equality, so we play safe
- ics { inert_irreds = irreds `snocBag` item }
+addIrred :: IrredCt -> InertIrreds -> InertIrreds
+addIrred extra irreds = irreds `snocBag` extra
-addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
- = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }
+updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans
+updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) }
-addInertItem _ _ item
- = pprPanic "upd_inert set: can't happen! Inserting " $
- ppr item -- Can't be CNonCanonical because they only land in inert_irreds
+delIrred :: IrredCt -> InertCans -> InertCans
+-- Remove a particular (Given) Irred, on the instructions of a plugin
+-- For some reason this is done vis the evidence Id, not the type
+-- Compare delEq. I have not idea why
+delIrred (IrredCt { ir_ev = ev }) ics
+ = updIrreds (filterBag keep) ics
+ where
+ ev_id = ctEvEvId ev
+ keep (IrredCt { ir_ev = ev' }) = ev_id /= ctEvEvId ev'
+
+foldIrreds :: (IrredCt -> b -> b) -> InertIrreds -> b -> b
+foldIrreds k irreds z = foldr k z irreds
+
+findMatchingIrreds :: InertIrreds -> CtEvidence
+ -> (Bag (IrredCt, SwapFlag), InertIrreds)
+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 irred
+ | irredCtPred irred `tcEqTypeNoKindCheck` pred = Left (irred, NotSwapped)
+ | otherwise = Right irred
+
+ match_eq eq_rel1 lty1 rty1 irred
+ | EqPred eq_rel2 lty2 rty2 <- classifyPredType (irredCtPred irred)
+ , eq_rel1 == eq_rel2
+ , Just swap <- match_eq_help lty1 rty1 lty2 rty2
+ = Left (irred, swap)
+ | otherwise
+ = Right irred
+
+ 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
-updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans
+{- Note [Solving irreducible equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#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 work-item 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 swap-flag so we can generate evidence
+that is the right way round too.
+-}
+
+{- *********************************************************************
+* *
+ Adding to and removing from the inert set
+* *
+* *
+********************************************************************* -}
+
+updGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans
-- Set the inert_given_eq_level to the current level (tclvl)
-- if the constraint is a given equality that should prevent
-- filling in an outer unification variable.
-- See Note [Tracking Given equalities]
-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })
+updGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })
| not (isGivenCt ct) = inerts
| not_equality ct = inerts -- See Note [Let-bound skolems]
| otherwise = inerts { inert_given_eq_lvl = ge_lvl'
@@ -1376,21 +1490,21 @@ kickOutRewritableLHS ko_spec new_fr@(_, new_role)
, inert_insts = insts_in }
kicked_out :: Cts
- kicked_out = (dicts_out `andCts` irs_out)
+ kicked_out = (fmap CDictCan dicts_out `andCts` fmap CIrredCan irs_out)
`extendCtsList` insts_out
`extendCtsList` map CEqCan tv_eqs_out
`extendCtsList` map CEqCan feqs_out
(tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs
(feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap
- (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap
- (irs_out, irs_in) = partitionBag kick_out_ct irreds
+ (dicts_out, dicts_in) = partitionDicts (kick_out_ct . CDictCan) dictmap
+ (irs_out, irs_in) = partitionBag (kick_out_ct . CIrredCan) 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
-- Kick-out for inert instances
- -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical
+ -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve
insts_out :: [Ct]
insts_in :: [QCInst]
(insts_out, insts_in)
@@ -1571,9 +1685,9 @@ Hence:
* We kick insolubles out of the inert set, if they can be
rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)
- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.
+ * We rewrite those insolubles in GHC.Tc.Solver.Equality
See Note [Make sure that insolubles are fully rewritten]
- in GHC.Tc.Solver.Canonical.
+ in GHC.Tc.Solver.Equality
-}
{- *********************************************************************
@@ -1603,13 +1717,13 @@ isOuterTyVar tclvl tv
noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool
-- True <=> there is no Irred looking like (N tys1 ~ N tys2)
--- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Canonical
+-- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Equality
-- This is the only call site.
noGivenNewtypeReprEqs tc inerts
= not (anyBag might_help (inert_irreds (inert_cans inerts)))
where
- might_help ct
- = case classifyPredType (ctPred ct) of
+ might_help irred
+ = case classifyPredType (ctEvPred (irredCtEvidence irred)) of
EqPred ReprEq t1 t2
| Just (tc1,_) <- tcSplitTyConApp_maybe t1
, tc == tc1
@@ -1621,7 +1735,7 @@ noGivenNewtypeReprEqs tc inerts
-- | Returns True iff there are no Given constraints that might,
-- potentially, match the given class consraint. This is used when checking to see if a
-- Given might overlap with an instance. See Note [Instance and Given overlap]
--- in "GHC.Tc.Solver.Interact"
+-- in GHC.Tc.Solver.Dict
noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool
noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys
= not $ anyBag matchable_given $
@@ -1629,9 +1743,9 @@ noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys
where
pred_w = mkClassPred clas tys
- matchable_given :: Ct -> Bool
- matchable_given ct
- | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct
+ matchable_given :: DictCt -> Bool
+ matchable_given (DictCt { di_ev = ev })
+ | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ev
= isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w
| otherwise
@@ -1639,7 +1753,7 @@ noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys
mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst
-- See Note [What might equal later?]
--- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact
+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict
mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc
| prohibitedSuperClassSolve given_loc wanted_loc
= Nothing
@@ -1784,7 +1898,7 @@ This is best understood by example.
where cbv = F a
The cbv is a cycle-breaker var which stands for F a. See
- Note [Type equality cycles] in GHC.Tc.Solver.Canonical.
+ Note [Type equality cycles] in GHC.Tc.Solver.Equality
This is just like case 6, and we say "no". Saying "no" here is
essential in getting the parser to type-check, with its use of DisambECP.
@@ -1902,3 +2016,199 @@ forAllCycleBreakerBindings_ :: Monad m
forAllCycleBreakerBindings_ (top_env :| _rest_envs) action
= forM_ top_env (uncurry action)
{-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later
+
+
+{- *********************************************************************
+* *
+ Solving one from another
+* *
+********************************************************************* -}
+
+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 inert item from it
+
+instance Outputable InteractResult where
+ ppr KeepInert = text "keep inert"
+ ppr KeepWork = text "keep work-item"
+
+solveOneFromTheOther :: Ct -- Inert (Dict or Irred)
+ -> Ct -- WorkItem (same predicate as inert)
+ -> InteractResult
+-- Precondition:
+-- * inert and work item represent evidence for the /same/ predicate
+-- * Both are CDictCan or CIrredCan
+--
+-- 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 ct_i ct_w
+ | CtWanted { ctev_loc = loc_w } <- ev_w
+ , prohibitedSuperClassSolve loc_i loc_w
+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
+ = -- Inert must be Given
+ KeepWork
+
+ | CtWanted {} <- ev_w
+ = -- Inert is Given or Wanted
+ case ev_i of
+ CtGiven {} -> KeepInert
+ -- work is Wanted; inert is Given: easy choice.
+
+ CtWanted {} -- Both are Wanted
+ -- If only one has no pending superclasses, use it
+ -- Otherwise we can get infinite superclass expansion (#22516)
+ -- in silly cases like class C T b => C a b where ...
+ | not is_psc_i, is_psc_w -> KeepInert
+ | is_psc_i, not is_psc_w -> KeepWork
+
+ -- If only one is a WantedSuperclassOrigin (arising from expanding
+ -- a Wanted class constraint), keep the other: wanted superclasses
+ -- may be unexpected by users
+ | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert
+ | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork
+
+ -- otherwise, just choose the lower span
+ -- reason: if we have something like (abs 1) (where the
+ -- Num constraint cannot be satisfied), it's better to
+ -- get an error about abs than about 1.
+ -- This test might become more elaborate if we see an
+ -- opportunity to improve the error messages
+ | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert
+ | otherwise -> KeepWork
+
+ -- From here on the work-item is Given
+
+ | CtWanted { ctev_loc = loc_i } <- ev_i
+ , prohibitedSuperClassSolve loc_w loc_i
+ = KeepInert -- Just discard the un-usable Given
+ -- This never actually happens because
+ -- Givens get processed first
+
+ | CtWanted {} <- ev_i
+ = KeepWork
+
+ -- From here on both are Given
+ -- See Note [Replacement vs keeping]
+
+ | lvl_i == lvl_w
+ = same_level_strategy
+
+ | otherwise -- Both are Given, levels differ
+ = different_level_strategy
+ where
+ ev_i = ctEvidence ct_i
+ ev_w = ctEvidence ct_w
+
+ pred = ctEvPred ev_i
+
+ loc_i = ctEvLoc ev_i
+ loc_w = ctEvLoc ev_w
+ orig_i = ctLocOrigin loc_i
+ orig_w = ctLocOrigin loc_w
+ lvl_i = ctLocLevel loc_i
+ lvl_w = ctLocLevel loc_w
+
+ is_psc_w = isPendingScDict ct_w
+ is_psc_i = isPendingScDict ct_i
+
+ is_wsc_orig_i = isWantedSuperclassOrigin orig_i
+ is_wsc_orig_w = isWantedSuperclassOrigin orig_w
+
+ different_level_strategy -- Both Given
+ | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert
+ | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork
+ -- See Note [Replacement vs keeping] part (1)
+ -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
+ -- in GHC.Tc.Solver.Dict
+
+ same_level_strategy -- Both Given
+ = case (orig_i, orig_w) of
+
+ (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w)
+ | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from
+ | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping]
+
+ -- Both blocked or both not blocked
+
+ | depth_w < depth_i -> KeepWork -- Case 2(c) from
+ | otherwise -> KeepInert -- Note [Replacement vs keeping]
+
+ (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping]
+
+ _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping]
+
+{-
+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! This is all implemented in
+solveOneFromTheOther.
+
+ 1) 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] in GHC.Tc.Solver.Dict
+
+ - 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 GHC.Tc.Solver.
+
+ It transpires that using the outermost one is responsible for an
+ 8% performance improvement in nofib cryptarithm2, compared to
+ just rolling the dice. I didn't investigate why.
+
+ 2) Constraints coming from the same level (i.e. same implication)
+
+ (a) If both are GivenSCOrigin, choose the one that is unblocked if possible
+ according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.
+
+ (b) Prefer constraints that are not superclass selections. Example:
+
+ f :: (Eq a, Ord a) => a -> Bool
+ f x = x == x
+
+ Eager superclass expansion gives us two [G] Eq a constraints. We
+ want to keep the one from the user-written Eq a, not the superclass
+ selection. This means we report the Ord a as redundant with
+ -Wredundant-constraints, not the Eq a.
+
+ Getting this wrong was #20602. See also
+ Note [Tracking redundant constraints] in GHC.Tc.Solver.
+
+ (c) If both are GivenSCOrigin, chooose the one with the shallower
+ superclass-selection depth, in the hope of identifying more correct
+ redundant constraints. This is really a generalization of point (b),
+ because the superclass depth of a non-superclass constraint is 0.
+
+ (If the levels differ, we definitely won't have both with GivenSCOrigin.)
+
+ (d) 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 GHC.Tc.Solver.Dict
+
+Doing the level-check 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 work-list: [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 level-check ensures that the inner implicit parameter wins.
+(Actually I think that the order in which the work-list is processed means
+that this chain of events won't happen, but that's very fragile.)
+-}
\ No newline at end of file
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
deleted file mode 100644
index e40478279cb2..000000000000
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ /dev/null
@@ -1,1274 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Tc.Solver.Interact (
- solveSimpleGivens, -- Solves [Ct]
- solveSimpleWanteds -- Solves Cts
- ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Solver.Canonical
-import GHC.Tc.Solver.Dict
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Instance.Class ( safeOverlap )
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Solver.Types
-import GHC.Tc.Solver.InertSet
-import GHC.Tc.Solver.Monad
-
-import GHC.Core.InstEnv ( Coherence(..) )
-import GHC.Core.Predicate
-import GHC.Core.Coercion
-
-import GHC.Builtin.Names ( ipClassKey )
-
-import GHC.Types.Unique( hasKey )
-import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit )
-
-import GHC.Data.Bag
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Monad ( foldlM )
-import GHC.Utils.Misc
-
-import GHC.Driver.Session
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import Data.List( deleteFirstsBy )
-import Data.Function ( on )
-
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Control.Monad
-
-{-
-**********************************************************************
-* *
-* Main Interaction Solver *
-* *
-**********************************************************************
-
-Note [Basic Simplifier Plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-1. Pick an element from the WorkList if there exists one with depth
- less than our context-stack depth.
-
-2. Run it down the 'stage' pipeline. Stages are:
- - canonicalization
- - inert reactions
- - spontaneous reactions
- - top-level interactions
- Each stage returns a StopOrContinue and may have sideeffected
- 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 it in the inerts and jump back to Step 1.
-
-If in Step 1 no such element exists, we have exceeded our context-stack
-depth and will simply fail.
--}
-
-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
--- 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 $ TcRnSimplifierTooManyIterations simples limit wc
- | isEmptyBag (wc_simple wc)
- = return (n,wc)
-
- | otherwise
- = do { -- Solve
- wc1 <- solve_simple_wanteds wc
-
- -- Run plugins
- ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
-
- ; if rerun_plugin
- then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
- ; go (n+1) limit wc2 } -- Loop
- else return (n, wc2) } -- Done
-
-
-solve_simple_wanteds :: WantedConstraints -> TcS 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, wc_errors = errs })
- = nestTcS $
- do { solveSimples simples1
- ; (implics2, unsolved) <- getUnsolvedInerts
- ; return (WC { wc_simple = unsolved
- , wc_impl = implics1 `unionBags` implics2
- , wc_errors = errs }) }
-
-{- 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
- 2. Try the plugin
- 3. If the plugin wants to run again, go back to step 1
--}
-
--- The main solver loop implements Note [Basic Simplifier Plan]
----------------------------------------------------------------
-solveSimples :: Cts -> TcS ()
--- Returns the final InertSet in TcS
--- Has no effect on work-list or residual-implications
--- The constraints are initially examined in left-to-right order
-
-solveSimples cts
- = {-# SCC "solveSimples" #-}
- do { emitWork 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 { solvers <- getTcPluginSolvers
- ; if null solvers then return [] else
- do { givens <- getInertGivens
- ; if null givens then return [] else
- do { p <- runTcPluginSolvers solvers (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 (rewritten, 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 })
- | isEmptyBag simples1
- = return (False, wc)
- | otherwise
- = do { solvers <- getTcPluginSolvers
- ; if null solvers then return (False, wc) else
-
- do { given <- getInertGivens
- ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs
- ; p <- runTcPluginSolvers solvers (given, bagToList wanted)
- ; let (_, solved_wanted) = pluginSolvedCts p
- (_, unsolved_wanted) = pluginInputCts p
- new_wanted = pluginNewCts p
- insols = pluginBadCts p
-
--- SLPJ: I'm deeply suspicious of this
--- ; updInertCans (removeInertCts $ solved_givens)
-
- ; mapM_ setEv solved_wanted
- ; return ( notNull (pluginNewCts p)
- , wc { wc_simple = listToBag new_wanted `andCts`
- listToBag unsolved_wanted `andCts`
- listToBag insols } ) } }
- where
- setEv :: (EvTerm,Ct) -> TcS ()
- setEv (ev,ct) = case ctEvidence ct of
- CtWanted { ctev_dest = dest } -> setWantedEvTerm dest IsCoherent ev -- TODO: plugins should be able to signal non-coherence
- _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
-
--- | A pair of (given, wanted) constraints to pass to plugins
-type SplitCts = ([Ct], [Ct])
-
--- | A solved pair of constraints, with evidence for wanteds
-type SolvedCts = ([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
- }
-
-getTcPluginSolvers :: TcS [TcPluginSolver]
-getTcPluginSolvers
- = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) }
-
--- | Starting from a pair of (given, wanted) constraints,
--- invoke each of the typechecker constraint-solving 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
--- re-invoked 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.
-runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
-runTcPluginSolvers solvers all_cts
- = do { ev_binds_var <- getTcEvBindsVar
- ; foldM (do_plugin ev_binds_var) initialProgress solvers }
- where
- do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
- do_plugin ev_binds_var p solver = do
- result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))
- return $ progress p result
-
- progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress
- progress p
- (TcPluginSolveResult
- { tcPluginInsolubleCts = bad_cts
- , tcPluginSolvedCts = solved_cts
- , tcPluginNewCts = new_cts
- }
- ) =
- p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)
- , pluginSolvedCts = add solved_cts (pluginSolvedCts p)
- , pluginNewCts = new_cts ++ pluginNewCts p
- , pluginBadCts = bad_cts ++ pluginBadCts p
- }
-
- initialProgress = TcPluginProgress all_cts ([], []) [] []
-
- discard :: [Ct] -> SplitCts -> SplitCts
- discard cts (xs, ys) =
- (xs `without` cts, ys `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, wanteds) (ev,ct) = case ctEvidence ct of
- CtGiven {} -> (ct:givens, wanteds)
- CtWanted {} -> (givens, (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 full_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 full_pipeline 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) }
- StartAgain ct -> pprPanic "runSolverPipeline: StartAgain" (ppr ct)
- }
- where
- run_pipeline :: [(String,SimplifierStage)] -> Ct -> TcS (StopOrContinue Ct)
- run_pipeline [] ct = return (ContinueWith ct)
- run_pipeline ((stage_name,stage):stages) ct
- = do { traceTcS ("runStage " ++ stage_name ++ " {")
- (text "workitem = " <+> ppr ct)
- ; res <- stage ct
- ; traceTcS ("end stage " ++ stage_name ++ " }") (ppr res)
- ; case res of
- Stop {} -> return res
- StartAgain ct -> run_pipeline full_pipeline ct
- ContinueWith ct -> run_pipeline stages ct }
-
-{-
-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 re-canonicalize and get nothing
--}
-
-thePipeline :: [(String,SimplifierStage)]
-thePipeline = [ ("canonicalization", GHC.Tc.Solver.Canonical.canonicalize)
- , ("interact with inerts", interactWithInertsStage)
- , ("top-level reactions", topReactionsStage) ]
-
-{-
-*********************************************************************************
-* *
- The interact-with-inert Stage
-* *
-*********************************************************************************
-
-Note [The Solver Invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We always add Givens first. So you might think that the solver has
-the invariant
-
- If the work-item 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 re-react it with the inert set. So we can attempt a
-reaction between inert c2 [W] and work-item c3 [G].
-
-It *is* true that [Solver Invariant]
- If the work-item is Given,
- AND there is a reaction
- then the inert item must Given
-or, equivalently,
- If the work-item is Given,
- and the inert item is Wanted
- then there is no reaction
--}
-
--- Interaction result of WorkItem <~> Ct
-
-interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- Precondition: if the workitem is a CEqCan then it will not be able to
--- react with anything at this stage (except, maybe, via a type family
--- dependency)
-
-interactWithInertsStage wi
- = do { inerts <- getTcSInerts
- ; let ics = inert_cans inerts
- ; case wi of
- CIrredCan {} -> interactIrred ics wi
- CDictCan {} -> interactDict ics wi
- CEqCan {} -> continueWith wi -- "Canonicalisation" stage is
- -- full solver for equalities
- _ -> pprPanic "interactWithInerts" (ppr wi) }
- -- 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 inert item from it
-
-instance Outputable InteractResult where
- ppr KeepInert = text "keep inert"
- ppr KeepWork = text "keep work-item"
-
-solveOneFromTheOther :: Ct -- Inert (Dict or Irred)
- -> Ct -- WorkItem (same predicate as inert)
- -> InteractResult
--- Precondition:
--- * inert and work item represent evidence for the /same/ predicate
--- * Both are CDictCan or CIrredCan
---
--- 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 ct_i ct_w
- | CtWanted { ctev_loc = loc_w } <- ev_w
- , prohibitedSuperClassSolve loc_i loc_w
- -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
- = -- Inert must be Given
- KeepWork
-
- | CtWanted {} <- ev_w
- = -- Inert is Given or Wanted
- case ev_i of
- CtGiven {} -> KeepInert
- -- work is Wanted; inert is Given: easy choice.
-
- CtWanted {} -- Both are Wanted
- -- If only one has no pending superclasses, use it
- -- Otherwise we can get infinite superclass expansion (#22516)
- -- in silly cases like class C T b => C a b where ...
- | not is_psc_i, is_psc_w -> KeepInert
- | is_psc_i, not is_psc_w -> KeepWork
-
- -- If only one is a WantedSuperclassOrigin (arising from expanding
- -- a Wanted class constraint), keep the other: wanted superclasses
- -- may be unexpected by users
- | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert
- | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork
-
- -- otherwise, just choose the lower span
- -- reason: if we have something like (abs 1) (where the
- -- Num constraint cannot be satisfied), it's better to
- -- get an error about abs than about 1.
- -- This test might become more elaborate if we see an
- -- opportunity to improve the error messages
- | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert
- | otherwise -> KeepWork
-
- -- From here on the work-item is Given
-
- | CtWanted { ctev_loc = loc_i } <- ev_i
- , prohibitedSuperClassSolve loc_w loc_i
- = KeepInert -- Just discard the un-usable Given
- -- This never actually happens because
- -- Givens get processed first
-
- | CtWanted {} <- ev_i
- = KeepWork
-
- -- From here on both are Given
- -- See Note [Replacement vs keeping]
-
- | lvl_i == lvl_w
- = same_level_strategy
-
- | otherwise -- Both are Given, levels differ
- = different_level_strategy
- where
- ev_i = ctEvidence ct_i
- ev_w = ctEvidence ct_w
-
- pred = ctEvPred ev_i
-
- loc_i = ctEvLoc ev_i
- loc_w = ctEvLoc ev_w
- orig_i = ctLocOrigin loc_i
- orig_w = ctLocOrigin loc_w
- lvl_i = ctLocLevel loc_i
- lvl_w = ctLocLevel loc_w
-
- is_psc_w = isPendingScDict ct_w
- is_psc_i = isPendingScDict ct_i
-
- is_wsc_orig_i = isWantedSuperclassOrigin orig_i
- is_wsc_orig_w = isWantedSuperclassOrigin orig_w
-
- different_level_strategy -- Both Given
- | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert
- | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork
- -- See Note [Replacement vs keeping] part (1)
- -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters]
-
- same_level_strategy -- Both Given
- = case (orig_i, orig_w) of
-
- (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w)
- | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from
- | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping]
-
- -- Both blocked or both not blocked
-
- | depth_w < depth_i -> KeepWork -- Case 2(c) from
- | otherwise -> KeepInert -- Note [Replacement vs keeping]
-
- (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping]
-
- _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping]
-
-{-
-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! This is all implemented in
-solveOneFromTheOther.
-
- 1) 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 GHC.Tc.Solver.
-
- It transpires that using the outermost one is responsible for an
- 8% performance improvement in nofib cryptarithm2, compared to
- just rolling the dice. I didn't investigate why.
-
- 2) Constraints coming from the same level (i.e. same implication)
-
- (a) If both are GivenSCOrigin, choose the one that is unblocked if possible
- according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.
-
- (b) Prefer constraints that are not superclass selections. Example:
-
- f :: (Eq a, Ord a) => a -> Bool
- f x = x == x
-
- Eager superclass expansion gives us two [G] Eq a constraints. We
- want to keep the one from the user-written Eq a, not the superclass
- selection. This means we report the Ord a as redundant with
- -Wredundant-constraints, not the Eq a.
-
- Getting this wrong was #20602. See also
- Note [Tracking redundant constraints] in GHC.Tc.Solver.
-
- (c) If both are GivenSCOrigin, chooose the one with the shallower
- superclass-selection depth, in the hope of identifying more correct
- redundant constraints. This is really a generalization of point (b),
- because the superclass depth of a non-superclass constraint is 0.
-
- (If the levels differ, we definitely won't have both with GivenSCOrigin.)
-
- (d) 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 GHC.Tc.Solver.Canonical
-
-Doing the level-check 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 work-list: [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 level-check ensures that the inner implicit parameter wins.
-(Actually I think that the order in which the work-list 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, non-droppable irreds does not
-do this matching. We thus might end up with several insoluble, non-droppable,
-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 ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason })
- | isInsolubleReason reason
- -- For insolubles, don't allow the constraint to be dropped
- -- which can happen with solveOneFromTheOther, so that
- -- we get distinct error messages with -fdefer-type-errors
- = continueWith ct_w
-
- | 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 { traceTcS "iteractIrred" $
- vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w))
- , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ]
- ; case solveOneFromTheOther ct_i ct_w of
- KeepInert -> do { setEvBindIfWanted ev_w IsCoherent (swap_me swap ev_i)
- ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) }
- KeepWork -> do { setEvBindIfWanted ev_i IsCoherent (swap_me swap ev_w)
- ; updInertIrreds (\_ -> others)
- ; continueWith ct_w } }
-
- | otherwise
- = continueWith ct_w
-
- where
- swap_me :: SwapFlag -> CtEvidence -> EvTerm
- swap_me swap ev
- = case swap of
- NotSwapped -> ctEvTerm ev
- IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm 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 (#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 work-item 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 swap-flag so we can generate evidence
-that is the right way round too.
--}
-
-{-
-*********************************************************************************
-* *
- 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
-top-level 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 top-level 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 (#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 (3-1). Really we should now rewrite to reduce the (3-1) 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 (3-1)) 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: 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 FlexibleInstances #-}
- {-# LANGUAGE MultiParamTypeClasses #-}
- module B where
-
- import A
-
- instance A a where
- int _ = 1
-
- instance C a [b] where
- m _ = id
-
-=========
- {-# LANGUAGE FlexibleContexts #-}
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE IncoherentInstances #-}
- {-# LANGUAGE MultiParamTypeClasses #-}
- 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 short-cut solver is
- try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
- -> CtEvidence -- Solve this
- -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
-Note that:
-
-* The CtEvidence is the goal to be solved
-
-* The MaybeT manages early failure if we find a subgoal that
- cannot be solved from instances.
-
-* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
- state that allows try_solve_from_instance to augment 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 #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.
-
-Note [No Given/Given fundeps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not create constraints from:
-* Given/Given interactions via functional dependencies or type family
- injectivity annotations.
-* Given/instance fundep interactions via functional dependencies or
- type family injectivity annotations.
-
-In this Note, all these interactions are called just "fundeps".
-
-We ingore such fundeps for several reasons:
-
-1. These fundeps will never serve a purpose in accepting more
- programs: Given constraints do not contain metavariables that could
- be unified via exploring fundeps. They *could* be useful in
- discovering inaccessible code. However, the constraints will be
- Wanteds, and as such will cause errors (not just warnings) if they
- go unsolved. Maybe there is a clever way to get the right
- inaccessible code warnings, but the path forward is far from
- clear. #12466 has further commentary.
-
-2. Furthermore, here is a case where a Given/instance interaction is actively
- harmful (from dependent/should_compile/RaeJobTalk):
-
- type family a == b :: Bool
- type family Not a = r | r -> a where
- Not False = True
- Not True = False
-
- [G] Not (a == b) ~ True
-
- Reacting this Given with the equations for Not produces
-
- [W] a == b ~ False
-
- This is indeed a true consequence, and would make sense as a fresh Given.
- But we don't have a way to produce evidence for fundeps, as a Wanted it
- is /harmful/: we can't prove it, and so we'll report an error and reject
- the program. (Previously fundeps gave rise to Deriveds, which
- carried no evidence, so it didn't matter that they could not be proved.)
-
-3. #20922 showed a subtle different problem with Given/instance fundeps.
- type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where
- ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss
- ...
-
- tclevel = 4
- [G] ZipCons is1 iss ~ (i : is2) : jss
-
- (The tclevel=4 means that this Given is at level 4.) The fundep tells us that
- 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification
- variable; we don't know what type it stands for. So we would emit
- [W] iss ~ is2 : beta
-
- Again we can't prove that equality; and worse we'll rewrite iss to
- (is2:beta) in deeply nested constraints inside this implication,
- where beta is untouchable (under other equality constraints), leading
- to other insoluble constraints.
-
-The bottom line: since we have no evidence for them, we should ignore Given/Given
-and Given/instance fundeps entirely.
--}
-
-interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
- | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
- , let ev_i = ctEvidence ct_i
- loc_i = ctEvLoc ev_i
- loc_w = ctEvLoc ev_w
- = -- 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"
-
- -- Next see if we are in "loopy-superclass" land. If so,
- -- we don't want to replace the (Given) inert with the
- -- (Wanted) work-item, or vice versa; we want to hang on
- -- to both, and try to solve the work-item via an instance.
- -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
- else if prohibitedSuperClassSolve loc_i loc_w
- then continueWith ct_w
- else
- do { -- The short-cut solver didn't fire, and loopy superclasses
- -- are dealt with, so we can either solve
- -- the inert from the work-item or vice-versa.
- ; case solveOneFromTheOther ct_i ct_w of
- KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr ct_w)
- ; setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
- ; return $ Stop ev_w (text "Dict equal" <+> ppr ct_w) }
- KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr ct_w)
- ; setEvBindIfWanted ev_i IsCoherent (ctEvTerm ev_w)
- ; updInertDicts $ \ ds -> delDict ds cls tys
- ; continueWith ct_w } } }
-
- | cls `hasKey` ipClassKey
- , isGiven ev_w
- = interactGivenIP inerts ct_w
-
- | otherwise
- = continueWith ct_w
-
-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 (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
-
- && 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 top-level proof.
- -- See Note [Shortcut solving: incoherence]
-
- && gopt Opt_SolveConstantDicts dflags
- -- Enabled by the -fsolve-constant-dicts flag
-
- = do { ev_binds_var <- getTcEvBindsVar
- ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
- getTcEvBindsMap ev_binds_var
- ; solved_dicts <- getSolvedDicts
-
- ; mb_stuff <- runMaybeT $ try_solve_from_instance
- (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 well-staged 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]
- :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
- -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
- try_solve_from_instance (ev_binds, solved_dicts) ev
- | let pred = ctEvPred ev
- loc = ctEvLoc ev
- , ClassPred cls tys <- classifyPredType pred
- = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
- ; case inst_res of
- OneInst { cir_new_theta = preds
- , cir_mk_ev = mk_ev
- , cir_coherence = coherence
- , cir_what = what }
- | safeOverlap what
- , all isTyFamFree preds -- Note [Shortcut solving: type families]
- -> do { let solved_dicts' = addDict solved_dicts cls tys ev
- -- 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)
- ; loc' <- lift $ checkInstanceOK loc what pred
- ; lift $ checkReductionDepth loc' pred
-
-
- ; evc_vs <- mapM (new_wanted_cached ev loc' 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) coherence ev_tm
-
- ; foldlM try_solve_from_instance
- (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 :: CtEvidence -> CtLoc
- -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
- new_wanted_cached ev_w loc 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 (ctEvRewriters ev_w) pty
- | otherwise = mzero
-
-
-{-
-**********************************************************************
-* *
- 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.
-
-See ticket #17104 for a rather tricky example of this overriding
-behaviour.
-
-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
- parameter---this 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.
-
-
-**********************************************************************
-* *
- The top-reaction Stage
-* *
-**********************************************************************
--}
-
-topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- The work item does not react with the inert set,
--- so try interaction with top-level instances.
-topReactionsStage work_item
- = do { traceTcS "doTopReact" (ppr work_item)
- ; case work_item of
-
- CDictCan {} ->
- do { inerts <- getTcSInerts
- ; doTopReactDict inerts work_item }
-
- CEqCan {} -> continueWith work_item -- "Canonicalisation" stage is
- -- full solver for equalities
-
- CIrredCan {} ->
- doTopReactOther work_item
-
- -- Any other work item does not react with any top-level equations
- _ -> continueWith work_item }
-
---------------------
-doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
--- Try local quantified constraints for
--- CEqCan e.g. (lhs ~# ty)
--- and CIrredCan e.g. (c a)
---
--- Why equalities? See GHC.Tc.Solver.Canonical
--- Note [Equality superclasses in quantified constraints]
-doTopReactOther work_item
- | isGiven ev
- = continueWith work_item
-
- | otherwise
- = do { res <- matchLocalInst pred loc
- ; case res of
- OneInst {} -> chooseInstance ev res
- _ -> continueWith work_item }
-
- where
- ev = ctEvidence work_item
- loc = ctEvLoc ev
- pred = ctEvPred ev
-
diff --git a/compiler/GHC/Tc/Solver/Irred.hs b/compiler/GHC/Tc/Solver/Irred.hs
new file mode 100644
index 000000000000..18b07c9d6420
--- /dev/null
+++ b/compiler/GHC/Tc/Solver/Irred.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module GHC.Tc.Solver.Irred(
+ solveIrred
+ ) where
+
+import GHC.Prelude
+
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Solver.InertSet
+import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
+import GHC.Tc.Solver.Monad
+import GHC.Tc.Types.Evidence
+
+import GHC.Core.Coercion
+import GHC.Core.InstEnv ( Coherence(..) )
+
+import GHC.Types.Basic( SwapFlag(..) )
+
+import GHC.Utils.Outputable
+
+import GHC.Data.Bag
+
+import Data.Void( Void )
+
+
+{- *********************************************************************
+* *
+* Irreducibles
+* *
+********************************************************************* -}
+
+solveIrred :: IrredCt -> SolverStage Void
+solveIrred irred
+ = do { simpleStage $ traceTcS "solveIrred:" (ppr irred)
+ ; tryInertIrreds irred
+ ; tryQCsIrredCt irred
+ ; simpleStage (updInertIrreds irred)
+ ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" }
+
+updInertIrreds :: IrredCt -> TcS ()
+updInertIrreds irred
+ = do { tc_lvl <- getTcLevel
+ ; updInertCans $ addIrredToCans tc_lvl irred }
+
+{- *********************************************************************
+* *
+* Inert Irreducibles
+* *
+********************************************************************* -}
+
+-- 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)
+tryInertIrreds :: IrredCt -> SolverStage ()
+tryInertIrreds irred
+ = Stage $ do { ics <- getInertCans
+ ; try_inert_irreds ics irred }
+
+try_inert_irreds :: InertCans -> IrredCt -> TcS (StopOrContinue ())
+
+try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason })
+ | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
+ , ((irred_i, swap) : _rest) <- bagToList matching_irreds
+ -- See Note [Multiple matching irreds]
+ , let ev_i = irredCtEvidence irred_i
+ ct_i = CIrredCan irred_i
+ , not (isInsolubleReason reason) || isGiven ev_i || isGiven ev_w
+ -- See Note [Insoluble irreds]
+ = do { traceTcS "iteractIrred" $
+ vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w))
+ , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ]
+ ; case solveOneFromTheOther ct_i ct_w of
+ KeepInert -> do { setEvBindIfWanted ev_w IsCoherent (swap_me swap ev_i)
+ ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) }
+ KeepWork -> do { setEvBindIfWanted ev_i IsCoherent (swap_me swap ev_w)
+ ; updInertCans (updIrreds (\_ -> others))
+ ; continueWith () } }
+
+ | otherwise
+ = continueWith ()
+
+ where
+ ct_w = CIrredCan irred_w
+
+ swap_me :: SwapFlag -> CtEvidence -> EvTerm
+ swap_me swap ev
+ = case swap of
+ NotSwapped -> ctEvTerm ev
+ IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev)))
+
+
+{- 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, non-droppable irreds does not
+do this matching. We thus might end up with several insoluble, non-droppable,
+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.
+
+Note [Insoluble irreds]
+~~~~~~~~~~~~~~~~~~~~~~~
+We don't allow an /insoluble/ Wanted to be solved from another identical
+Wanted. We want to keep all the insoluble Wanteds distinct, so that we get
+distinct error messages with -fdefer-type-errors
+
+However we /do/ allow an insoluble constraint (Given or Wanted) to be solved
+from an identical insoluble Given. This might seem a little odd, but there is
+lots of discussion in #23413 and #17543. We currently implement the PermissivePlan
+of #23413. An alternative would be the LibertarianPlan, but that is harder to
+implemnent.
+
+By "identical" we include swapping. See Note [Solving irreducible equalities]
+in GHC.Tc.Solver.InertSet.
+
+Test cases that are involved bkpfail24.run, T15450, GivenForallLoop, T20189, T8392a.
+-}
+
+{- *********************************************************************
+* *
+* Quantified constraints
+* *
+********************************************************************* -}
+
+tryQCsIrredCt :: IrredCt -> SolverStage ()
+-- Try local quantified constraints for
+-- and CIrredCan e.g. (c a)
+tryQCsIrredCt (IrredCt { ir_ev = ev })
+ | isGiven ev
+ = Stage $ continueWith ()
+
+ | otherwise
+ = Stage $ do { res <- matchLocalInst pred loc
+ ; case res of
+ OneInst {} -> chooseInstance ev res
+ _ -> continueWith () }
+ where
+ loc = ctEvLoc ev
+ pred = ctEvPred ev
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 08982a1a3243..be23518539bb 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -32,11 +32,12 @@ module GHC.Tc.Solver.Monad (
QCInst(..),
-- The pipeline
- StopOrContinue(..), continueWith, stopWith, andWhenContinue,
- startAgainWith,
+ StopOrContinue(..), continueWith, stopWith,
+ startAgainWith, SolverStage(Stage, runSolverStage), simpleStage,
+ stopWithStage,
-- Tracing etc
- panicTcS, traceTcS,
+ panicTcS, traceTcS, tryEarlyAbortTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
resetUnificationFlag, setUnificationFlag,
@@ -64,26 +65,26 @@ module GHC.Tc.Solver.Monad (
-- Inerts
- updInertTcS, updInertCans, updInertDicts, updInertIrreds,
+ updInertSet, updInertCans,
getHasGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertGivens,
getInertInsols, getInnermostGivenEqLevel,
- getTcSInerts, setTcSInerts,
+ getInertSet,
getUnsolvedInerts,
removeInertCts, getPendingGivenScs,
- addInertCan, insertFunEq, addInertForAll,
+ insertFunEq, addInertForAll,
emitWorkNC, emitWork,
lookupInertDict,
-- The Model
- kickOutAfterUnification,
+ kickOutAfterUnification, kickOutRewritable,
-- Inert Safe Haskell safe-overlap failures
addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
getSafeOverlapFailures,
-- Inert solved dictionaries
- addSolvedDict, lookupSolvedDict,
+ updSolvedDicts, lookupSolvedDict,
-- Irreds
foldIrreds,
@@ -203,16 +204,57 @@ import GHC.Data.Graph.Directed
{- *********************************************************************
* *
- StopOrContinue
+ SolverStage and StopOrContinue
* *
********************************************************************* -}
+{- Note [The SolverStage monad]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The SolverStage monad allows us to write simple code like that in
+GHC.Tc.Solver.solveEquality. At the time of writing it looked like
+this (may get out of date but the idea is clear):
+
+solveEquality :: ... -> SolverStage Void
+solveEquality ev eq_rel ty1 ty2
+ = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2
+ ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2'
+ ; case mb_canon of {
+ Left irred_ct -> do { tryQCsIrredEqCt irred_ct
+ ; solveIrred irred_ct } ;
+ Right eq_ct -> do { tryInertEqs eq_ct
+ ; tryFunDeps eq_ct
+ ; tryQCsEqCt eq_ct
+ ; simpleStage (updInertEqs eq_ct)
+ ; stopWithStage (eqCtEvidence eq_ct) ".." }}}
+
+Each sub-stage can elect to
+ (a) ContinueWith: continue to the next stasge
+ (b) StartAgain: start again at the beginning of the pipeline
+ (c) Stop: stop altogether; constraint is solved
+
+These three possiblities are described by the `StopOrContinue` data type.
+The `SolverStage` monad does the plumbing.
+
+Notes:
+
+(SM1) Each individual stage pretty quickly drops down into
+ TcS (StopOrContinue a)
+ because the monadic plumbing of `SolverStage` is relatively ineffienct,
+ with that three-way split.
+
+(SM2) We use `SolverStage Void` to express the idea that ContinueWith is
+ impossible; we don't need to pattern match on it as a possible outcome:A
+ see GHC.Tc.Solver.Solve.solveOne. To that end, ContinueWith is strict.
+-}
+
data StopOrContinue a
- = StartAgain a -- Constraint is not solved, but some unifications
+ = StartAgain Ct -- Constraint is not solved, but some unifications
-- happened, so go back to the beginning of the pipeline
- | ContinueWith a -- The constraint was not solved, although it may have
- -- been rewritten
+ | ContinueWith !a -- The constraint was not solved, although it may have
+ -- been rewritten. It is strict so that
+ -- ContinueWith Void can't happen; see (SM2) in
+ -- Note [The SolverStage monad]
| Stop CtEvidence -- The (rewritten) constraint was solved
SDoc -- Tells how it was solved
@@ -220,11 +262,31 @@ data StopOrContinue a
deriving (Functor)
instance Outputable a => Outputable (StopOrContinue a) where
- ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev
+ ppr (Stop ev s) = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev)
ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
ppr (StartAgain w) = text "StartAgain" <+> ppr w
-startAgainWith :: a -> TcS (StopOrContinue a)
+newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) }
+ deriving( Functor )
+
+instance Applicative SolverStage where
+ pure x = Stage (return (ContinueWith x))
+ (<*>) = ap
+
+instance Monad SolverStage where
+ return = pure
+ (Stage m) >>= k = Stage $
+ do { soc <- m
+ ; case soc of
+ StartAgain x -> return (StartAgain x)
+ Stop ev d -> return (Stop ev d)
+ ContinueWith x -> runSolverStage (k x) }
+
+simpleStage :: TcS a -> SolverStage a
+-- Always does a ContinueWith; no Stop or StartAgain
+simpleStage thing = Stage (do { res <- thing; continueWith res })
+
+startAgainWith :: Ct -> TcS (StopOrContinue a)
startAgainWith ct = return (StartAgain ct)
continueWith :: a -> TcS (StopOrContinue a)
@@ -233,15 +295,8 @@ continueWith ct = return (ContinueWith ct)
stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
stopWith ev s = return (Stop ev (text s))
-andWhenContinue :: TcS (StopOrContinue a)
- -> (a -> TcS (StopOrContinue a))
- -> TcS (StopOrContinue a)
-andWhenContinue tcs1 tcs2
- = do { r <- tcs1
- ; case r of
- ContinueWith ct -> tcs2 ct
- _ -> return r }
-infixr 0 `andWhenContinue` -- allow chaining with ($)
+stopWithStage :: CtEvidence -> String -> SolverStage a
+stopWithStage ev s = Stage (stopWith ev s)
{- *********************************************************************
@@ -295,95 +350,24 @@ the following two constraints as different (#22223):
The main logic that allows us to pick local instances, even in the presence of
duplicates, is explained in Note [Use only the best matching quantified constraint]
-in GHC.Tc.Solver.Interact.
+in GHC.Tc.Solver.Dict.
-}
{- *********************************************************************
* *
- Adding an inert
+ Kicking out
* *
************************************************************************
-
-Note [Adding an equality to the InertCans]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When adding an equality to the inerts:
-
-* 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 [Kick out existing binding for implicit parameter]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have (typecheck/should_compile/ImplicitParamFDs)
- flub :: (?x :: Int) => (Int, Integer)
- flub = (?x, let ?x = 5 in ?x)
-When we are checking the last ?x occurrence, we guess its type
-to be a fresh unification variable alpha and emit an (IP "x" alpha)
-constraint. But the given (?x :: Int) has been translated to an
-IP "x" Int constraint, which has a functional dependency from the
-name to the type. So fundep interaction tells us that alpha ~ Int,
-and we get a type error. This is bad.
-
-Instead, we wish to excise any old given for an IP when adding a
-new one. We also must make sure not to float out
-any IP constraints outside an implication that binds an IP of
-the same name; see GHC.Tc.Solver.floatConstraints.
-}
-addInertCan :: Ct -> TcS ()
--- Precondition: item /is/ canonical
--- See Note [Adding an equality to the InertCans]
-addInertCan ct =
- do { traceTcS "addInertCan {" $
- text "Trying to insert new inert item:" <+> ppr ct
- ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} ->
- when (abort_flag && insolubleEqCt ct) TcM.failM)
- ; ics <- getInertCans
- ; ics <- maybeKickOut ics ct
- ; tclvl <- getTcLevel
- ; setInertCans (addInertItem tclvl ics ct)
-
- ; traceTcS "addInertCan }" $ empty }
-
-maybeKickOut :: InertCans -> Ct -> TcS InertCans
--- For a CEqCan, kick out any inert that can be rewritten by the CEqCan
-maybeKickOut ics ct
- | CEqCan eq_ct <- ct
- = do { (_, ics') <- kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct))
- (eqCtFlavourRole eq_ct) ics
- ; return ics' }
-
- -- See [Kick out existing binding for implicit parameter]
- | isGivenCt ct
- , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct
- , isIPClass cls
- , Just ip_name <- isStrLitTy ip_name_strty
- -- Would this be more efficient if we used findDictsByClass and then delDict?
- = let dict_map = inert_dicts ics
- dict_map' = filterDicts doesn't_match_ip_name dict_map
-
- doesn't_match_ip_name :: Ct -> Bool
- doesn't_match_ip_name ct
- | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct)
- = inert_ip_name /= ip_name
-
- | otherwise
- = True
-
- in
- return (ics { inert_dicts = dict_map' })
-
- | otherwise
- = return ics
-----------------------------------------
-kickOutRewritable :: KickOutSpec -> CtFlavourRole
- -> InertCans -> TcS (Int, InertCans)
-kickOutRewritable ko_spec new_fr ics
- = do { let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics
+kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS ()
+kickOutRewritable ko_spec new_fr
+ = do { ics <- getInertCans
+ ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics
n_kicked = lengthBag kicked_out
+ ; setInertCans ics'
; unless (isEmptyBag kicked_out) $
do { emitWork kicked_out
@@ -408,22 +392,18 @@ kickOutRewritable ko_spec new_fr ics
hang (text "Kick out")
2 (vcat [ text "n-kicked =" <+> int n_kicked
, text "kicked_out =" <+> ppr kicked_out
- , text "Residual inerts =" <+> ppr ics' ]) }
-
- ; return (n_kicked, ics') }
+ , text "Residual inerts =" <+> ppr ics' ]) } }
-kickOutAfterUnification :: [TcTyVar] -> TcS Int
+kickOutAfterUnification :: [TcTyVar] -> TcS ()
kickOutAfterUnification tvs
| null tvs
- = return 0
+ = return ()
| otherwise
- = do { ics <- getInertCans
- ; let tv_set = mkVarSet tvs
- ; (n_kicked, ics2) <- kickOutRewritable (KOAfterUnify tv_set)
- (Given, NomEq) ics
- -- Given because the tv := xi is given; NomEq because
- -- only nominal equalities are solved by unification
- ; setInertCans ics2
+ = do { let tv_set = mkVarSet tvs
+
+ ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq)
+ -- Given because the tv := xi is given; NomEq because
+ -- only nominal equalities are solved by unification
-- Set the unification flag if we have done outer unifications
-- that might affect an earlier implication constraint
@@ -436,7 +416,7 @@ kickOutAfterUnification tvs
; return n_kicked }
kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
--- See Wrinkle (EIK2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
+-- See Wrinkle (EIK2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality
-- It's possible that this could just go ahead and unify, but could there be occurs-check
-- problems? Seems simpler just to kick out.
kickOutAfterFillingCoercionHole hole
@@ -445,7 +425,7 @@ kickOutAfterFillingCoercionHole hole
n_kicked = lengthBag kicked_out
; unless (n_kicked == 0) $
- do { updWorkListTcS (extendWorkListCts kicked_out)
+ do { updWorkListTcS (extendWorkListCts (fmap CIrredCan kicked_out))
; csTraceTcS $
hang (text "Kick out, hole =" <+> ppr hole)
2 (vcat [ text "n-kicked =" <+> int n_kicked
@@ -454,7 +434,7 @@ kickOutAfterFillingCoercionHole hole
; setInertCans ics' }
where
- kick_out :: InertCans -> (Cts, InertCans)
+ kick_out :: InertCans -> (Bag IrredCt, InertCans)
kick_out ics@(IC { inert_irreds = irreds })
= -- We only care about irreds here, because any constraint blocked
-- by a coercion hole is an irred. See wrinkle (EIK2a) in
@@ -463,10 +443,10 @@ kickOutAfterFillingCoercionHole hole
where
(irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds
- kick_ct :: Ct -> Bool
+ kick_ct :: IrredCt -> Bool
-- True: kick out; False: keep.
kick_ct ct
- | CIrredCan { cc_ev = ev, cc_reason = reason } <- ct
+ | IrredCt { ir_ev = ev, ir_reason = reason } <- ct
, CtWanted { ctev_rewriters = RewriterSet rewriters } <- ev
, NonCanonicalReason ctyeq <- reason
, ctyeq `cterHasProblem` cteCoercionHole
@@ -476,44 +456,41 @@ kickOutAfterFillingCoercionHole hole
= False
--------------
-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
+addInertSafehask :: InertCans -> DictCt -> InertCans
+addInertSafehask ics item
+ = ics { inert_safehask = addDict item (inert_dicts ics) }
-insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()
+insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS ()
-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
insertSafeOverlapFailureTcS what item
| safeOverlap what = return ()
| otherwise = updInertCans (\ics -> addInertSafehask ics item)
-getSafeOverlapFailures :: TcS Cts
+getSafeOverlapFailures :: TcS (Bag DictCt)
-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
getSafeOverlapFailures
= do { IC { inert_safehask = safehask } <- getInertCans
- ; return $ foldDicts consCts safehask emptyCts }
+ ; return $ foldDicts consBag safehask emptyBag }
--------------
-addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()
+updSolvedDicts :: InstanceWhat -> DictCt -> TcS ()
-- Conditionally add a new item in the solved set of the monad
-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
-addSolvedDict what item cls tys
- | isWanted item
+updSolvedDicts what dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ | isWanted ev
, instanceReturnsDictCon what
- = do { traceTcS "updSolvedSetTcs:" $ ppr item
- ; updInertTcS $ \ ics ->
- ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
+ = do { traceTcS "updSolvedDicts:" $ ppr dict_ct
+ ; updInertSet $ \ ics ->
+ ics { inert_solved_dicts = addSolvedDict cls tys ev (inert_solved_dicts ics) } }
| otherwise
= return ()
getSolvedDicts :: TcS (DictMap CtEvidence)
-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }
+getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }
setSolvedDicts :: DictMap CtEvidence -> TcS ()
setSolvedDicts solved_dicts
- = updInertTcS $ \ ics ->
+ = updInertSet $ \ ics ->
ics { inert_solved_dicts = solved_dicts }
{- *********************************************************************
@@ -522,23 +499,23 @@ setSolvedDicts solved_dicts
* *
********************************************************************* -}
-updInertTcS :: (InertSet -> InertSet) -> TcS ()
+updInertSet :: (InertSet -> InertSet) -> TcS ()
-- Modify the inert set with the supplied function
-updInertTcS upd_fn
- = do { is_var <- getTcSInertsRef
+updInertSet upd_fn
+ = do { is_var <- getInertSetRef
; 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) }
+getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) }
setInertCans :: InertCans -> TcS ()
-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
+setInertCans ics = updInertSet $ \ 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
+ = do { is_var <- getInertSetRef
; wrapTcS (do { inerts <- TcM.readTcRef is_var
; let (res, cans') = upd_fn (inert_cans inerts)
; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
@@ -547,23 +524,13 @@ updRetInertCans upd_fn
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) }
+ = updInertSet $ \ 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 ()
+updInertSafehask :: (DictMap DictCt -> DictMap DictCt) -> TcS ()
-- Modify the inert set with the supplied function
updInertSafehask upd_fn
= updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask 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 InertEqs
getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
@@ -586,19 +553,20 @@ getInnermostGivenEqLevel = do { inert <- getInertCans
-- want to consider a pattern match that introduces insoluble Givens to be
-- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver).
getInertInsols :: TcS Cts
-getInertInsols = do { inert <- getInertCans
- ; let irreds = inert_irreds inert
- unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey
- ; return $ unsats `unionBags` filterBag insolubleCt irreds }
+getInertInsols
+ = do { inert <- getInertCans
+ ; let insols = filterBag insolubleIrredCt (inert_irreds inert)
+ unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey
+ ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols }
getInertGivens :: TcS [Ct]
-- Returns the Given constraints in the inert set
getInertGivens
= do { inerts <- getInertCans
- ; let all_cts = foldIrreds (:) (inert_irreds inerts)
- $ foldDicts (:) (inert_dicts inerts)
- $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts)
- $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts)
+ ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts)
+ $ foldDicts ((:) . CDictCan) (inert_dicts inerts)
+ $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts)
+ $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts)
$ []
; return (filter isGivenCt all_cts) }
@@ -620,28 +588,27 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
-- there are never any Wanteds in the inert set
(sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
where
- sc_pending = sc_pend_insts ++ sc_pend_dicts
+ sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts
+ sc_pend_dicts :: [DictCt]
sc_pend_dicts = foldDicts get_pending dicts []
dicts' = foldr exhaustAndAdd dicts sc_pend_dicts
(sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
- get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc > 0
+ exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt
+ exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts
+ -- Exhaust the fuel for this constraint before adding it as
+ -- we don't want to expand these constraints again
+
+ get_pending :: DictCt -> [DictCt] -> [DictCt] -- Get dicts with cc_pend_sc > 0
get_pending dict dicts
- | isPendingScDict dict
- , belongs_to_this_level (ctEvidence dict)
+ | isPendingScDictCt dict
+ , belongs_to_this_level (dictCtEvidence dict)
= dict : dicts
| otherwise
= dicts
- exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
- exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
- -- exhaust the fuel for this constraint before adding it as
- -- we don't want to expand these constraints again
- = addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
- exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
-
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst cts qci@(QCI { qci_ev = ev })
| Just qci' <- pendingScInst_maybe qci
@@ -655,7 +622,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
-- We only want Givens from this level; see (3a) in
- -- Note [The superclass story] in GHC.Tc.Solver.Canonical
+ -- Note [The superclass story] in GHC.Tc.Solver.Dict
getUnsolvedInerts :: TcS ( Bag Implication
, Cts ) -- All simple constraints
@@ -671,36 +638,35 @@ getUnsolvedInerts
, inert_dicts = idicts
} <- getInertCans
- ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved_eq tv_eqs emptyCts
- unsolved_fun_eqs = foldFunEqs add_if_unsolved_eq fun_eqs emptyCts
- unsolved_irreds = Bag.filterBag isWantedCt irreds
- unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts
- unsolved_others = unionManyBags [ unsolved_irreds
- , unsolved_dicts ]
+ ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts
+ unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts
+ unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds
+ unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts
; 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 "dicts =" <+> ppr unsolved_dicts
+ , text "irreds =" <+> ppr unsolved_irreds
, text "implics =" <+> ppr implics ]
; return ( implics, unsolved_tv_eqs `unionBags`
unsolved_fun_eqs `unionBags`
- unsolved_others) }
+ unsolved_irreds `unionBags`
+ unsolved_dicts ) }
where
- add_if_unsolved :: Ct -> Cts -> Cts
- add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts
- | otherwise = cts
-
- add_if_unsolved_eq :: EqCt -> Cts -> Cts
- add_if_unsolved_eq eq_ct cts | isWanted (eq_ev eq_ct) = CEqCan eq_ct `consCts` cts
- | otherwise = cts
+ add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts
+ add_if_unsolved mk_ct thing cts
+ | isWantedCt ct = ct `consCts` cts
+ | otherwise = cts
+ where
+ ct = mk_ct thing
-getHasGivenEqs :: TcLevel -- TcLevel of this implication
- -> TcS ( HasGivenEqs -- are there Given equalities?
- , Cts ) -- Insoluble equalities arising from givens
+getHasGivenEqs :: TcLevel -- TcLevel of this implication
+ -> TcS ( HasGivenEqs -- are there Given equalities?
+ , InertIrreds ) -- Insoluble equalities arising from givens
-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
getHasGivenEqs tclvl
= do { inerts@(IC { inert_irreds = irreds
@@ -726,8 +692,10 @@ getHasGivenEqs tclvl
, text "Insols:" <+> ppr given_insols]
; return (has_ge, given_insols) }
where
- insoluble_given_equality ct
- = insolubleEqCt ct && isGivenCt ct
+ insoluble_given_equality :: IrredCt -> Bool
+ -- Check for unreachability; specifically do not include UserError/Unsatisfiable
+ insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason })
+ = isInsolubleReason reason && isGiven ev
removeInertCts :: [Ct] -> InertCans -> InertCans
-- ^ Remove inert constraints from the 'InertCans', for use when a
@@ -735,28 +703,19 @@ removeInertCts :: [Ct] -> InertCans -> InertCans
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 }
-
- CEqCan eq_ct -> delEq is eq_ct
-
- CIrredCan {} -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }
-
- CQuantCan {} -> panic "removeInertCt: CQuantCan"
- CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
-
-eqCt :: Ct -> Ct -> Bool
--- Equality via ctEvId
-eqCt c c' = ctEvId c == ctEvId c'
+removeInertCt is ct
+ = case ct of
+ CDictCan dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) }
+ CEqCan eq_ct -> delEq eq_ct is
+ CIrredCan ir_ct -> delIrred ir_ct is
+ CQuantCan {} -> panic "removeInertCt: CQuantCan"
+ CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
-- | Looks up a family application in the inerts.
lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target?
-> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))
lookupFamAppInert rewrite_pred fam_tc tys
- = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
+ = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet
; return (lookup_inerts inert_funeqs) }
where
lookup_inerts inert_funeqs
@@ -770,9 +729,9 @@ 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
+ = do { inerts <- getInertSet
; let mb_solved = lookupSolvedDict inerts loc cls tys
- mb_inert = fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)
+ mb_inert = fmap dictCtEvidence (lookupInertDict (inert_cans inerts) loc cls tys)
; return $ do -- Maybe monad
found_ev <- mb_solved `mplus` mb_inert
@@ -787,24 +746,20 @@ lookupInInerts loc pty
= return Nothing
-- | Look up a dictionary inert.
-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct
+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe DictCt
lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
- = case findDict dicts loc cls tys of
- Just ct -> Just ct
- _ -> Nothing
+ = findDict dicts loc cls tys
-- | Look up a solved inert.
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
+ = findDict solved loc cls tys
---------------------------
lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)
lookupFamAppCache fam_tc tys
- = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
+ = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet
; case findFunEq famapp_cache fam_tc tys of
result@(Just redn) ->
do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
@@ -819,30 +774,20 @@ extendFamAppCache tc xi_args stuff@(Reduction _ ty)
; when (gopt Opt_FamAppCache dflags) $
do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
, ppr ty ])
- ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
+ ; updInertSet $ \ is@(IS { inert_famapp_cache = fc }) ->
is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
-- Remove entries from the cache whose evidence mentions variables in the
-- supplied set
dropFromFamAppCache :: VarSet -> TcS ()
dropFromFamAppCache varset
- = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts
- ; let filtered = filterTcAppMap check famapp_cache
- ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }
+ = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) ->
+ inerts { inert_famapp_cache = filterTcAppMap check famapp_cache })
where
check :: Reduction -> Bool
check redn
= not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)
-{- *********************************************************************
-* *
- Irreds
-* *
-********************************************************************* -}
-
-foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
-foldIrreds k irreds z = foldr k z irreds
-
{-
************************************************************************
* *
@@ -953,7 +898,12 @@ warnTcS, addErrTcS :: TcRnMessage -> TcS ()
failTcS = wrapTcS . TcM.failWith
warnTcS msg = wrapTcS (TcM.addDiagnostic msg)
addErrTcS = wrapTcS . TcM.addErr
-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc
+panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc
+
+tryEarlyAbortTcS :: TcS ()
+-- Abort (fail in the monad) if the abort_on_insoluble flag is on
+tryEarlyAbortTcS
+ = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM)
-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.
ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()
@@ -1037,9 +987,9 @@ runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts inerts tcs = do
ev_binds_var <- TcM.newTcEvBinds
runTcSWithEvBinds' False False ev_binds_var $ do
- setTcSInerts inerts
+ setInertSet inerts
a <- tcs
- new_inerts <- getTcSInerts
+ new_inerts <- getInertSet
return (a, new_inerts)
runTcSWithEvBinds :: EvBindsVar
@@ -1050,7 +1000,7 @@ runTcSWithEvBinds = runTcSWithEvBinds' True False
runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
-- Don't if you want to reuse the InertSet.
-- See also Note [Type equality cycles]
- -- in GHC.Tc.Solver.Canonical
+ -- in GHC.Tc.Solver.Equality
-> Bool
-> EvBindsVar
-> TcS a
@@ -1243,17 +1193,17 @@ if you do so.
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Getter of inerts and worklist
-getTcSInertsRef :: TcS (IORef InertSet)
-getTcSInertsRef = TcS (return . tcs_inerts)
+getInertSetRef :: TcS (IORef InertSet)
+getInertSetRef = TcS (return . tcs_inerts)
-getTcSWorkListRef :: TcS (IORef WorkList)
-getTcSWorkListRef = TcS (return . tcs_worklist)
+getInertSet :: TcS InertSet
+getInertSet = getInertSetRef >>= readTcRef
-getTcSInerts :: TcS InertSet
-getTcSInerts = getTcSInertsRef >>= readTcRef
+setInertSet :: InertSet -> TcS ()
+setInertSet is = do { r <- getInertSetRef; writeTcRef r is }
-setTcSInerts :: InertSet -> TcS ()
-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }
+getTcSWorkListRef :: TcS (IORef WorkList)
+getTcSWorkListRef = TcS (return . tcs_worklist)
getWorkListImplics :: TcS (Bag Implication)
getWorkListImplics
@@ -1377,7 +1327,7 @@ selectNextWorkItem
Nothing -> return Nothing ;
Just (ct, new_wl) ->
do { -- checkReductionDepth (ctLoc ct) (ctPred ct)
- -- This is done by GHC.Tc.Solver.Interact.chooseInstance
+ -- This is done by GHC.Tc.Solver.Dict.chooseInstance
; writeTcRef wl_var new_wl
; return (Just ct) } } }
@@ -1892,7 +1842,6 @@ newWantedNC loc rewriters pty
| otherwise
= newWantedEvVarNC loc rewriters pty
--- --------- Check done in GHC.Tc.Solver.Interact.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
@@ -2187,7 +2136,7 @@ checkTypeEq ev eq_rel lhs rhs
PuFail reason -> return (PuFail reason)
PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs
; emitWork new_givens
- ; updInertTcS (addCycleBreakerBindings prs)
+ ; updInertSet (addCycleBreakerBindings prs)
; return (pure redn) } }
| otherwise -- Wanted
@@ -2263,7 +2212,7 @@ mkTEFA_Break ev eq_rel breaker
-------------------------
-- | Fill in CycleBreakerTvs with the variables they stand for.
--- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.
+-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality
restoreTyVarCycles :: InertSet -> TcM ()
restoreTyVarCycles is
= forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 64d590cbe99a..bf4353ce129c 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -92,9 +92,9 @@ runRewriteCtEv ev
runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet)
runRewrite loc flav eq_rel thing_inside
= do { rewriters_ref <- newTcRef emptyRewriterSet
- ; let fmode = RE { re_loc = loc
- , re_flavour = flav
- , re_eq_rel = eq_rel
+ ; let fmode = RE { re_loc = loc
+ , re_flavour = flav
+ , re_eq_rel = eq_rel
, re_rewriters = rewriters_ref }
; res <- runRewriteM thing_inside fmode
; rewriters <- readTcRef rewriters_ref
@@ -316,7 +316,7 @@ For example, see the RTRNotFollowed case in rewriteTyVar.
Why have these invariants on rewriting? Because we sometimes use typeKind
during canonicalisation, and we want this kind to be zonked (e.g., see
-GHC.Tc.Solver.Canonical.canEqCanLHS).
+GHC.Tc.Solver.Equality.canEqCanLHS).
Rewriting is always homogeneous. That is, the kind of the result of rewriting is
always the same as the kind of the input, modulo zonking. More formally:
@@ -514,7 +514,7 @@ rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
-- Important: look at the *reduced* type, so that any unzonked variables
-- in kinds are gone and the getRuntimeRep succeeds.
- -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.
+ -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Equality.
; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)
res_rep = getRuntimeRep (reductionReducedType res_redn)
@@ -668,7 +668,7 @@ rewrite_vector ki roles tys
{- Note [Do not rewrite newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Canonical
+We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Equality
Note [Unwrap newtypes first]. But that turned out to be a bad idea because
of recursive newtypes, as that Note says. So be careful if you re-add it!
@@ -1057,8 +1057,9 @@ This means that rewriting must be recursive, but it does allow
[G] b ~ Maybe c
This avoids "saturating" the Givens, which can save a modest amount of work.
-It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert
-only if (a) the work item can rewrite the inert AND
+It is easy to implement, in GHC.Tc.Solver.InertSet.kickOutRewritableLHS, by
+only kicking out an inert only if
+ (a) the work item can rewrite the inert AND
(b) the inert cannot rewrite the work item
This is significantly harder to think about. It can save a LOT of work
diff --git a/compiler/GHC/Tc/Solver/Solve.hs b/compiler/GHC/Tc/Solver/Solve.hs
new file mode 100644
index 000000000000..9e520b84bfbc
--- /dev/null
+++ b/compiler/GHC/Tc/Solver/Solve.hs
@@ -0,0 +1,720 @@
+{-# LANGUAGE RecursiveDo #-}
+
+module GHC.Tc.Solver.Solve (
+ solveSimpleGivens, -- Solves [Ct]
+ solveSimpleWanteds -- Solves Cts
+ ) where
+
+import GHC.Prelude
+
+import GHC.Tc.Solver.Dict
+import GHC.Tc.Solver.Equality( solveEquality )
+import GHC.Tc.Solver.Irred( solveIrred )
+import GHC.Tc.Solver.Rewrite( rewrite )
+import GHC.Tc.Errors.Types
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types
+import GHC.Tc.Types.Origin
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Solver.InertSet
+import GHC.Tc.Solver.Monad
+
+import GHC.Core.InstEnv ( Coherence(..) )
+import GHC.Core.Predicate
+import GHC.Core.Reduction
+import GHC.Core.Coercion
+import GHC.Core.Class( classHasSCs )
+
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Basic ( IntWithInf, intGtLimit )
+
+import GHC.Data.Bag
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc
+
+import GHC.Driver.Session
+
+import Data.List( deleteFirstsBy )
+
+import Control.Monad
+import Data.Semigroup as S
+import Data.Void( Void )
+
+{-
+**********************************************************************
+* *
+* Main Solver *
+* *
+**********************************************************************
+
+Note [Basic Simplifier Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1. Pick an element from the WorkList if there exists one with depth
+ less than our context-stack depth.
+
+2. Run it down the 'stage' pipeline. Stages are:
+ - canonicalization
+ - inert reactions
+ - spontaneous reactions
+ - top-level interactions
+ Each stage returns a StopOrContinue and may have sideeffected
+ 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 it in the inerts and jump back to Step 1.
+
+If in Step 1 no such element exists, we have exceeded our context-stack
+depth and will simply fail.
+-}
+
+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
+-- 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)
+ -- See Note [The solveSimpleWanteds loop]
+ go n limit wc
+ | n `intGtLimit` limit
+ = failTcS $ TcRnSimplifierTooManyIterations simples limit wc
+ | isEmptyBag (wc_simple wc)
+ = return (n,wc)
+
+ | otherwise
+ = do { -- Solve
+ wc1 <- solve_simple_wanteds wc
+
+ -- Run plugins
+ ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
+
+ ; if rerun_plugin
+ then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
+ ; go (n+1) limit wc2 } -- Loop
+ else return (n, wc2) } -- Done
+
+
+solve_simple_wanteds :: WantedConstraints -> TcS 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, wc_errors = errs })
+ = nestTcS $
+ do { solveSimples simples1
+ ; (implics2, unsolved) <- getUnsolvedInerts
+ ; return (WC { wc_simple = unsolved
+ , wc_impl = implics1 `unionBags` implics2
+ , wc_errors = errs }) }
+
+{- 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
+ 2. Try the plugin
+ 3. If the plugin wants to run again, go back to step 1
+-}
+
+{-
+************************************************************************
+* *
+ Solving flat constraints: solveSimples
+* *
+********************************************************************* -}
+
+-- The main solver loop implements Note [Basic Simplifier Plan]
+---------------------------------------------------------------
+solveSimples :: Cts -> TcS ()
+-- Returns the final InertSet in TcS
+-- Has no effect on work-list or residual-implications
+-- The constraints are initially examined in left-to-right order
+
+solveSimples cts
+ = {-# SCC "solveSimples" #-}
+ do { emitWork cts; solve_loop }
+ where
+ solve_loop
+ = {-# SCC "solve_loop" #-}
+ do { sel <- selectNextWorkItem
+ ; case sel of
+ Nothing -> return ()
+ Just ct -> do { solveOne ct
+ ; solve_loop } }
+
+solveOne :: Ct -> TcS () -- Solve one constraint
+solveOne workItem
+ = do { wl <- getWorkList
+ ; inerts <- getInertSet
+ ; 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
+ ; solve workItem }
+ where
+ solve :: Ct -> TcS ()
+ solve ct
+ = do { traceTcS "solve {" (text "workitem = " <+> ppr ct)
+ ; res <- runSolverStage (solveCt ct)
+ ; traceTcS "end solve }" (ppr res)
+ ; case res of
+ StartAgain ct -> do { traceTcS "Go round again" (ppr ct)
+ ; solve ct }
+
+ Stop ev s -> do { traceFireTcS ev s
+ ; traceTcS "End solver pipeline }" empty
+ ; return () }
+
+ -- ContinueWith can't happen: res :: SolverStage Void
+ -- solveCt either solves the constraint, or puts
+ -- the unsolved constraint in the inert set.
+ }
+
+{- *********************************************************************
+* *
+* Solving one constraint: solveCt
+* *
+************************************************************************
+
+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 user-written code come into being as
+CNonCanonicals. 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 rewritten and then decomposed into one of several forms
+(see type Ct in GHC.Tc.Types).
+
+When an already-canonicalized 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.
+-}
+
+solveCt :: Ct -> SolverStage Void
+-- The Void result tells us that solveCt cannot return
+-- a ContinueWith; it must return Stop or StartAgain.
+solveCt (CNonCanonical ev) = solveNC ev
+solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev
+
+solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs, eq_rhs = rhs }))
+ = solveEquality ev eq_rel (canEqLHSType lhs) rhs
+
+solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
+ = do { ev <- rewriteEvidence ev
+ -- It is (much) easier to rewrite and re-classify than to
+ -- rewrite the pieces and build a Reduction that will rewrite
+ -- the whole constraint
+ ; case classifyPredType (ctEvPred ev) of
+ ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc
+ _ -> pprPanic "SolveCt" (ppr ev) }
+
+solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))
+ = do { ev <- rewriteEvidence ev
+ -- It is easier to rewrite and re-classify than to rewrite
+ -- the pieces and build a Reduction that will rewrite the
+ -- whole constraint
+ ; case classifyPredType (ctEvPred ev) of
+ ClassPred cls tys
+ -> solveDict (DictCt { di_ev = ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = pend_sc })
+ _ -> pprPanic "solveCt" (ppr ev) }
+
+------------------
+solveNC :: CtEvidence -> SolverStage Void
+solveNC ev
+ = -- Instead of rewriting the evidence before classifying, it's possible we
+ -- can make progress without the rewrite. Try this first.
+ -- For insolubles (all of which are equalities), do /not/ rewrite the arguments
+ -- In #14350 doing so led entire-unnecessary 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
+ case classifyPredType (ctEvPred ev) of {
+ EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ;
+ _ ->
+
+ -- Do rewriting on the constraint, especially zonking
+ do { ev <- rewriteEvidence ev
+ ; let irred = IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }
+
+ -- And then re-classify
+ ; case classifyPredType (ctEvPred ev) of
+ ClassPred cls tys -> solveDictNC ev cls tys
+ ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p
+ IrredPred {} -> solveIrred irred
+ EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2
+ -- This case only happens if (say) `c` is unified with `a ~# b`,
+ -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep
+
+ }}
+
+
+{- *********************************************************************
+* *
+* Quantified constraints
+* *
+********************************************************************* -}
+
+{- Note [Quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The -XQuantifiedConstraints extension allows type-class contexts like this:
+
+ data Rose f x = Rose x (f (Rose f x))
+
+ instance (Eq a, forall b. Eq b => Eq (f b))
+ => Eq (Rose f a) where
+ (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
+
+Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
+This quantified constraint is needed to solve the
+ [W] (Eq (f (Rose f x)))
+constraint which arises form the (==) definition.
+
+The wiki page is
+ https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints
+which in turn contains a link to the GHC Proposal where the change
+is specified, and a Haskell Symposium paper about it.
+
+We implement two main extensions to the design in the paper:
+
+ 1. We allow a variable in the instance head, e.g.
+ f :: forall m a. (forall b. m b) => D (m a)
+ Notice the 'm' in the head of the quantified constraint, not
+ a class.
+
+ 2. We support superclasses to quantified constraints.
+ For example (contrived):
+ f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
+ f x y = x==y
+ Here we need (Eq (m a)); but the quantified constraint deals only
+ with Ord. But we can make it work by using its superclass.
+
+Here are the moving parts
+ * Language extension {-# LANGUAGE QuantifiedConstraints #-}
+ and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
+
+ * A new form of evidence, EvDFun, that is used to discharge
+ such wanted constraints
+
+ * checkValidType gets some changes to accept forall-constraints
+ only in the right places.
+
+ * Predicate.Pred gets a new constructor ForAllPred, and
+ and classifyPredType analyses a PredType to decompose
+ the new forall-constraints
+
+ * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,
+ which holds all the Given forall-constraints. In effect,
+ such Given constraints are like local instance decls.
+
+ * When trying to solve a class constraint, via
+ GHC.Tc.Solver.Instance.Class.matchInstEnv, use the InstEnv from inert_insts
+ so that we include the local Given forall-constraints
+ in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.)
+
+ * `solveForAll` deals with solving a forall-constraint. See
+ Note [Solving a Wanted forall-constraint]
+
+ * We augment the kick-out code to kick out an inert
+ forall constraint if it can be rewritten by a new
+ type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable
+
+Note that a quantified constraint is never /inferred/
+(by GHC.Tc.Solver.simplifyInfer). A function can only have a
+quantified constraint in its type if it is given an explicit
+type signature.
+
+-}
+
+solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType
+ -> TcS (StopOrContinue Void)
+-- NC: this came from CNonCanonical, so we have not yet expanded superclasses
+-- Precondition: already rewritten by inert set
+solveForAllNC ev tvs theta pred
+ | isGiven ev -- See Note [Eagerly expand given superclasses]
+ , Just (cls, tys) <- cls_pred_tys_maybe
+ = do { dflags <- getDynFlags
+ ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys
+ -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
+ ; emitWork (listToBag sc_cts)
+ ; solveForAll ev tvs theta pred doNotExpand }
+ -- doNotExpand: as we have already (eagerly) expanded superclasses for this class
+
+ | otherwise
+ = do { dflags <- getDynFlags
+ ; let fuel | Just (cls, _) <- cls_pred_tys_maybe
+ , classHasSCs cls = qcsFuel dflags
+ -- See invariants (a) and (b) in QCI.qci_pend_sc
+ -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
+ -- See Note [Quantified constraints]
+ | otherwise = doNotExpand
+ ; solveForAll ev tvs theta pred fuel }
+ where
+ cls_pred_tys_maybe = getClassPredTys_maybe pred
+
+solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel
+ -> TcS (StopOrContinue Void)
+-- Precondition: already rewritten by inert set
+solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
+ tvs theta pred _fuel
+ = -- See Note [Solving a Wanted forall-constraint]
+ setSrcSpan (getLclEnvLoc $ ctLocEnv loc) $
+ -- This setSrcSpan is important: the emitImplicationTcS uses that
+ -- TcLclEnv for the implication, and that in turn sets the location
+ -- for the Givens when solving the constraint (#21006)
+ do { let empty_subst = mkEmptySubst $ mkInScopeSet $
+ tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
+ is_qc = IsQC (ctLocOrigin loc)
+
+ -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
+ -- in GHC.Tc.Utils.TcType
+ -- Very like the code in tcSkolDFunType
+ ; rec { skol_info <- mkSkolemInfo skol_info_anon
+ ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs
+ ; let inst_pred = substTy subst pred
+ inst_theta = substTheta subst theta
+ skol_info_anon = InstSkol is_qc (get_size inst_pred) }
+
+ ; given_ev_vars <- mapM newEvVar inst_theta
+ ; (lvl, (w_id, wanteds))
+ <- pushLevelNoWorkList (ppr skol_info) $
+ do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc)
+ -- Set the thing to prove to have a ScOrigin, so we are
+ -- careful about its termination checks.
+ -- See (QC-INV) in Note [Solving a Wanted forall-constraint]
+ ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred
+ ; return ( ctEvEvId wanted_ev
+ , unitBag (mkNonCanonical wanted_ev)) }
+
+ ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs
+ given_ev_vars wanteds
+
+ ; setWantedEvTerm dest IsCoherent $
+ EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
+ , et_binds = ev_binds, et_body = w_id }
+
+ ; stopWith ev "Wanted forall-constraint" }
+ where
+ -- Getting the size of the head is a bit horrible
+ -- because of the special treament for class predicates
+ get_size pred = case classifyPredType pred of
+ ClassPred cls tys -> pSizeClassPred cls tys
+ _ -> pSizeType pred
+
+ -- See Note [Solving a Given forall-constraint]
+solveForAll ev@(CtGiven {}) tvs _theta pred fuel
+ = do { addInertForAll qci
+ ; stopWith ev "Given forall-constraint" }
+ where
+ qci = QCI { qci_ev = ev, qci_tvs = tvs
+ , qci_pred = pred, qci_pend_sc = fuel }
+
+{- Note [Solving a Wanted forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a wanted forall (quantified) constraint
+ [W] df :: forall ab. (Eq a, Ord b) => C x a b
+is delightfully easy. Just build an implication constraint
+ forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
+and discharge df thus:
+ df = /\ab. \g1 g2. let <binds> in d
+where <binds> is filled in by solving the implication constraint.
+All the machinery is to hand; there is little to do.
+
+The tricky point is about termination: see #19690. We want to maintain
+the invariant (QC-INV):
+
+ (QC-INV) Every quantified constraint returns a non-bottom dictionary
+
+just as every top-level instance declaration guarantees to return a non-bottom
+dictionary. But as #19690 shows, it is possible to get a bottom dicionary
+by superclass selection if we aren't careful. The situation is very similar
+to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance;
+and we use the same solution:
+
+* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size))
+* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc)
+
+Both of these things are done in solveForAll. Now the mechanism described
+in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over.
+
+Note [Solving a Given forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a Given constraint
+ [G] df :: forall ab. (Eq a, Ord b) => C x a b
+we just add it to TcS's local InstEnv of known instances,
+via addInertForall. Then, if we look up (C x Int Bool), say,
+we'll find a match in the InstEnv.
+
+
+************************************************************************
+* *
+ Evidence transformation
+* *
+************************************************************************
+-}
+
+rewriteEvidence :: CtEvidence -> SolverStage CtEvidence
+-- (rewriteEvidence old_ev new_pred co do_next)
+-- Main purpose: create new evidence for new_pred;
+-- unless new_pred is cached already
+-- * Calls do_next with (new_ev :: new_pred), with same wanted/given 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
+-- * Stops if new_ev is already cached
+--
+-- Old evidence New predicate is Return new evidence
+-- flavour of same flavor
+-- -------------------------------------------------------------------
+-- Wanted Already solved or in inert Stop
+-- Not do_next new_evidence
+--
+-- Given Already in inert Stop
+-- Not do_next new_evidence
+
+{- Note [Rewriting with Refl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the coercion is just reflexivity then you may re-use the same
+evidence 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.
+
+The rewriter preserves type synonyms, so they should appear in new_pred
+as well as in old_pred; that is important for good error messages.
+
+If we are rewriting with Refl, then there are no new rewriters to add to
+the rewriter set. We check this with an assertion.
+ -}
+
+
+rewriteEvidence ev
+ = Stage $ do { traceTcS "rewriteEvidence" (ppr ev)
+ ; (redn, rewriters) <- rewrite ev (ctEvPred ev)
+ ; finish_rewrite ev redn rewriters }
+
+finish_rewrite :: CtEvidence -- ^ old evidence
+ -> Reduction -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate
+ -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds]
+ -- in GHC.Tc.Types.Constraint
+ -> TcS (StopOrContinue CtEvidence)
+finish_rewrite old_ev (Reduction co new_pred) rewriters
+ | isReflCo co -- See Note [Rewriting with Refl]
+ = assert (isEmptyRewriterSet rewriters) $
+ continueWith (setCtEvPredType old_ev new_pred)
+
+finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
+ (Reduction co new_pred) rewriters
+ = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
+ do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
+ ; continueWith new_ev }
+ where
+ -- mkEvCast optimises ReflCo
+ new_tm = mkEvCast (evId old_evar)
+ (downgradeRole Representational (ctEvRole ev) co)
+
+finish_rewrite ev@(CtWanted { ctev_dest = dest
+ , ctev_loc = loc
+ , ctev_rewriters = rewriters })
+ (Reduction co new_pred) new_rewriters
+ = do { mb_new_ev <- newWanted loc rewriters' new_pred
+ ; massert (coercionRole co == ctEvRole ev)
+ ; setWantedEvTerm dest IsCoherent $
+ mkEvCast (getEvExpr mb_new_ev)
+ (downgradeRole Representational (ctEvRole ev) (mkSymCo co))
+ ; case mb_new_ev of
+ Fresh new_ev -> continueWith new_ev
+ Cached _ -> stopWith ev "Cached wanted" }
+ where
+ rewriters' = rewriters S.<> new_rewriters
+
+{- *******************************************************************
+* *
+* Typechecker plugins
+* *
+******************************************************************* -}
+
+-- | 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 { solvers <- getTcPluginSolvers
+ ; if null solvers then return [] else
+ do { givens <- getInertGivens
+ ; if null givens then return [] else
+ do { traceTcS "runTcPluginsGiven {" (ppr givens)
+ ; p <- runTcPluginSolvers solvers (givens,[])
+ ; let (solved_givens, _) = pluginSolvedCts p
+ insols = map (ctIrredCt PluginReason) (pluginBadCts p)
+ ; updInertCans (removeInertCts solved_givens .
+ updIrreds (addIrreds insols) )
+ ; traceTcS "runTcPluginsGiven }" $
+ vcat [ text "solved_givens:" <+> ppr solved_givens
+ , text "insols:" <+> ppr insols
+ , text "new:" <+> ppr (pluginNewCts p) ]
+ ; return (pluginNewCts p) } } }
+
+-- | Given a bag of (rewritten, 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 })
+ | isEmptyBag simples1
+ = return (False, wc)
+ | otherwise
+ = do { solvers <- getTcPluginSolvers
+ ; if null solvers then return (False, wc) else
+
+ do { given <- getInertGivens
+ ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs
+
+ ; traceTcS "Running plugins (" (vcat [ text "Given:" <+> ppr given
+ , text "Watned:" <+> ppr wanted ])
+ ; p <- runTcPluginSolvers solvers (given, bagToList wanted)
+ ; let (_, solved_wanted) = pluginSolvedCts p
+ (_, unsolved_wanted) = pluginInputCts p
+ new_wanted = pluginNewCts p
+ insols = pluginBadCts p
+ all_new_wanted = listToBag new_wanted `andCts`
+ listToBag unsolved_wanted `andCts`
+ listToBag insols
+
+-- SLPJ: I'm deeply suspicious of this
+-- ; updInertCans (removeInertCts $ solved_givens)
+
+ ; mapM_ setEv solved_wanted
+
+ ; traceTcS "Finished plugins }" (ppr new_wanted)
+ ; return ( notNull (pluginNewCts p)
+ , wc { wc_simple = all_new_wanted } ) } }
+ where
+ setEv :: (EvTerm,Ct) -> TcS ()
+ setEv (ev,ct) = case ctEvidence ct of
+ CtWanted { ctev_dest = dest } -> setWantedEvTerm dest IsCoherent ev -- TODO: plugins should be able to signal non-coherence
+ _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
+
+-- | A pair of (given, wanted) constraints to pass to plugins
+type SplitCts = ([Ct], [Ct])
+
+-- | A solved pair of constraints, with evidence for wanteds
+type SolvedCts = ([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
+ }
+
+getTcPluginSolvers :: TcS [TcPluginSolver]
+getTcPluginSolvers
+ = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) }
+
+-- | Starting from a pair of (given, wanted) constraints,
+-- invoke each of the typechecker constraint-solving 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
+-- re-invoked 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.
+runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
+runTcPluginSolvers solvers all_cts
+ = do { ev_binds_var <- getTcEvBindsVar
+ ; foldM (do_plugin ev_binds_var) initialProgress solvers }
+ where
+ do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
+ do_plugin ev_binds_var p solver = do
+ result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))
+ return $ progress p result
+
+ progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress
+ progress p
+ (TcPluginSolveResult
+ { tcPluginInsolubleCts = bad_cts
+ , tcPluginSolvedCts = solved_cts
+ , tcPluginNewCts = new_cts
+ }
+ ) =
+ p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)
+ , pluginSolvedCts = add solved_cts (pluginSolvedCts p)
+ , pluginNewCts = new_cts ++ pluginNewCts p
+ , pluginBadCts = bad_cts ++ pluginBadCts p
+ }
+
+ initialProgress = TcPluginProgress all_cts ([], []) [] []
+
+ discard :: [Ct] -> SplitCts -> SplitCts
+ discard cts (xs, ys) =
+ (xs `without` cts, ys `without` cts)
+
+ without :: [Ct] -> [Ct] -> [Ct]
+ without = deleteFirstsBy eq_ct
+
+ eq_ct :: Ct -> Ct -> Bool
+ eq_ct 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, wanteds) (ev,ct) = case ctEvidence ct of
+ CtGiven {} -> (ct:givens, wanteds)
+ CtWanted {} -> (givens, (ev,ct):wanteds)
+
+
diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs
index 648f451eee87..d47eef71b728 100644
--- a/compiler/GHC/Tc/Solver/Types.hs
+++ b/compiler/GHC/Tc/Solver/Types.hs
@@ -4,17 +4,17 @@
-- | Utility types used within the constraint solver
module GHC.Tc.Solver.Types (
-- Inert CDictCans
- DictMap, emptyDictMap, addDict,
+ DictMap, emptyDictMap,
findDictsByTyConKey, findDictsByClass,
- addDictsByClass, delDict, foldDicts, filterDicts, findDict,
- dictsToBag, partitionDicts,
+ foldDicts, findDict,
+ dictsToBag,
FunEqMap, emptyFunEqs, findFunEq, insertFunEq,
findFunEqsByTyCon,
TcAppMap, emptyTcAppMap, isEmptyTcAppMap,
insertTcApp, alterTcApp, filterTcAppMap,
- tcAppMapToBag, foldTcAppMap,
+ tcAppMapToBag, foldTcAppMap, delTcApp,
EqualCtList, filterEqualCtList, addToEqualCtList
@@ -133,9 +133,6 @@ emptyDictMap = emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict m loc cls tys
- | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]
- = Nothing
-
| Just {} <- isCallStackPred cls tys
, isPushCallStackOrigin (ctLocOrigin loc)
= Nothing -- See Note [Solving CallStack constraints]
@@ -151,56 +148,14 @@ findDictsByTyConKey m tc
| Just tm <- lookupUDFM_Directly m tc = foldTM consBag tm emptyBag
| otherwise = emptyBag
-delDict :: DictMap a -> Class -> [Type] -> DictMap a
-delDict m cls tys = delTcApp m (classTyCon cls) tys
-
-addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
-addDict m cls tys item = insertTcApp m (classTyCon cls) tys item
-
-addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
-addDictsByClass m cls items
- = extendDTyConEnv m (classTyCon cls) (foldr 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, emptyDictMap)
- 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
-{- 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). #14218.
-
-We deal with this by arranging that we always fail when looking up a
-tuple constraint that hides an implicit parameter. Note 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]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Solving CallStack constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.
Suppose f :: HasCallStack => blah. Then
@@ -212,7 +167,7 @@ Suppose f :: HasCallStack => blah. Then
IP "callStack" CallStack
See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by
+* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by
pushing the call-site info on the stack, and changing the CtOrigin
to record that has been done.
Bind: s1 = pushCallStack <site-info> s2
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index a2d8a30c9c42..6a8f6988f099 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1655,7 +1655,7 @@ Answer:
it is the superclass of an unblocked dictionary (wrinkle (W1)),
that is Paterson-smaller than the instance head.
- This is implemented in GHC.Tc.Solver.Canonical.mk_strict_superclasses
+ This is implemented in GHC.Tc.Solver.Dict.mk_strict_superclasses
(in the mk_given_loc helper function).
* Superclass "Wanted" constraints have CtOrigin of (ScOrigin NakedSc)
@@ -1679,12 +1679,12 @@ However, we want to provide a migration strategy for users, to avoid suddenly
breaking their code going when upgrading to GHC 9.6. To this effect, we temporarily
continue to allow the constraint solver to create these potentially non-terminating
solutions, but emit a loud warning when doing so: see
-GHC.Tc.Solver.Interact.tryLastResortProhibitedSuperclass.
+GHC.Tc.Solver.Dict.tryLastResortProhibitedSuperclass.
Users can silence the warning by manually adding the necessary constraint to the
context. GHC will then keep this user-written Given, dropping the Given arising
from superclass expansion which has greater SC depth, as explained in
-Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
+Note [Replacement vs keeping] in GHC.Tc.Solver.Dict.
Note [Silent superclass arguments] (historical interest only)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 1c6a31987ad2..83812690c2db 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -6,29 +6,31 @@
-- | This module defines types and simple operations over constraints, as used
-- in the type-checker and constraint solver.
module GHC.Tc.Types.Constraint (
- -- QCInst
- QCInst(..), pendingScInst_maybe,
-
- -- Canonical constraints
+ -- Constraints
Xi, Ct(..), Cts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts, emptyCts, andCts, ctsPreds,
- isPendingScDict, pendingScDict_maybe,
+ isPendingScDictCt, isPendingScDict, pendingScDict_maybe,
superClassesMightHelp, getPendingWantedScs,
isWantedCt, isGivenCt,
isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg,
isUnsatisfiableCt_maybe,
- ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
+ ctEvidence, updCtEvidence,
+ ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
ctRewriters,
ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,
- mkNonCanonical, mkNonCanonicalCt, mkGivens,
- mkIrredCt,
- ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
- ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
- ctEvRewriters,
+ mkNonCanonical, mkGivens,
tyCoVarsOfCt, tyCoVarsOfCts,
tyCoVarsOfCtList, tyCoVarsOfCtsList,
+ -- Particular forms of constraint
+ EqCt(..), eqCtEvidence, eqCtLHS,
+ DictCt(..), dictCtEvidence,
+ IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred,
+
+ -- QCInst
+ QCInst(..), pendingScInst_maybe,
+
ExpansionFuel, doNotExpand, consumeFuel, pendingFuel,
assertFuelPrecondition, assertFuelPreconditionStrict,
@@ -44,7 +46,6 @@ module GHC.Tc.Types.Constraint (
cterRemoveProblem, cterHasOccursCheck, cterFromKind,
- EqCt(..), eqCtLHS, eqCtEvidence,
CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,
canEqLHSKind, canEqLHSType, eqCanEqLHS,
@@ -56,8 +57,8 @@ module GHC.Tc.Types.Constraint (
isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,
addInsols, dropMisleading, addSimples, addImplics, addHoles,
addNotConcreteError, addDelayedErrors,
- tyCoVarsOfWC,
- tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt, insolubleCt,
+ tyCoVarsOfWC, tyCoVarsOfWCList,
+ insolubleWantedCt, insolubleCt, insolubleIrredCt,
insolubleImplic, nonDefaultableTyVarsOfWC,
Implication(..), implicationPrototype, checkTelescopeSkol,
@@ -74,12 +75,15 @@ module GHC.Tc.Types.Constraint (
-- CtEvidence
CtEvidence(..), TcEvDest(..),
- mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc,
isWanted, isGiven,
+ ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
+ ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
+ ctEvRewriters, ctEvUnique, tcEvDestUnique,
+ mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc,
ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens,
tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,
- ctEvUnique, tcEvDestUnique,
+ -- RewriterSet
RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,
-- exported concretely only for anyUnfilledCoercionHoles
addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts,
@@ -194,45 +198,35 @@ assertFuelPreconditionStrict :: ExpansionFuel -> a -> a
assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError
data Ct
- -- Atomic canonical constraints
- = CDictCan { -- e.g. Num ty
- cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
-
- cc_class :: Class,
- cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi
-
- cc_pend_sc :: ExpansionFuel
- -- See Note [The superclass story] in GHC.Tc.Solver.Canonical
- -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver
- -- Invariants: cc_pend_sc > 0 <=>
- -- (a) cc_class has superclasses
- -- (b) those superclasses are not yet explored
- }
-
- | CIrredCan { -- These stand for yet-unusable predicates
- cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
- cc_reason :: CtIrredReason
-
- -- For the might-be-soluble case, the ctev_pred of the evidence is
- -- of form (tv xi1 xi2 ... xin) with a tyvar at the head
- -- or (lhs1 ~ ty2) where the CEqCan kind invariant (TyEq:K) fails
- -- See Note [CIrredCan constraints]
-
- -- The definitely-insoluble case is for things like
- -- Int ~ Bool tycons don't match
- -- a ~ [a] occurs check
+ = CDictCan DictCt
+ | CIrredCan IrredCt -- A "irreducible" constraint (non-canonical)
+ | CEqCan EqCt -- A canonical equality constraint
+ | CQuantCan QCInst -- A quantified constraint
+ | CNonCanonical CtEvidence -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
+
+--------------- DictCt --------------
+
+data DictCt -- e.g. Num ty
+ = DictCt { di_ev :: CtEvidence -- See Note [Ct/evidence invariant]
+
+ , di_cls :: Class
+ , di_tys :: [Xi] -- di_tys are rewritten w.r.t. inerts, so Xi
+
+ , di_pend_sc :: ExpansionFuel
+ -- See Note [The superclass story] in GHC.Tc.Solver.Dict
+ -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver
+ -- Invariants: di_pend_sc > 0 <=>
+ -- (a) di_cls has superclasses
+ -- (b) those superclasses are not yet explored
}
- | CNonCanonical { -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
- cc_ev :: CtEvidence
- }
+dictCtEvidence :: DictCt -> CtEvidence
+dictCtEvidence = di_ev
- | CEqCan EqCt -- A canonical equality constraint
+instance Outputable DictCt where
+ ppr dict = ppr (CDictCan dict)
- | CQuantCan QCInst -- A quantified constraint
- -- NB: I expect to make more of the cases in Ct
- -- look like this, with the payload in an
- -- auxiliary type
+--------------- EqCt --------------
{- Note [Canonical equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -266,11 +260,12 @@ were to mention the LHS: this would cause a loop in rewriting.
We thus perform an occurs-check. There is, of course, some subtlety:
-* For type variables, the occurs-check looks deeply. This is because
- a CEqCan over a meta-variable is also used to inform unification,
- in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears
- anywhere, at all, in the RHS, unification will create an infinite
- structure, which is bad.
+* For type variables, the occurs-check looks deeply including kinds of
+ type variables. This is because a CEqCan over a meta-variable is
+ also used to inform unification, in
+ GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears
+ anywhere in the RHS, at all, unification will create an infinite
+ structure which is bad.
* For type family applications, the occurs-check is shallow; it looks
only in places where we might rewrite. (Specifically, it does not
@@ -297,13 +292,6 @@ data EqCt -- An equality constraint; see Note [Canonical equalities]
eq_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev
}
-eqCtEvidence :: EqCt -> CtEvidence
-eqCtEvidence = eq_ev
-
-eqCtLHS :: EqCt -> CanEqLHS
-eqCtLHS = eq_lhs
-
-------------
-- | A 'CanEqLHS' is a type that can appear on the left of a canonical
-- equality: a type variable or /exactly-saturated/ type family application.
data CanEqLHS
@@ -315,9 +303,40 @@ instance Outputable CanEqLHS where
ppr (TyVarLHS tv) = ppr tv
ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)
-------------
+eqCtEvidence :: EqCt -> CtEvidence
+eqCtEvidence = eq_ev
+
+eqCtLHS :: EqCt -> CanEqLHS
+eqCtLHS = eq_lhs
+
+--------------- IrredCt --------------
+
+data IrredCt -- These stand for yet-unusable predicates
+ -- See Note [CIrredCan constraints]
+ = IrredCt { ir_ev :: CtEvidence -- See Note [Ct/evidence invariant]
+ , ir_reason :: CtIrredReason }
+
+mkIrredCt :: CtIrredReason -> CtEvidence -> Ct
+mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason })
+
+irredCtEvidence :: IrredCt -> CtEvidence
+irredCtEvidence = ir_ev
+
+irredCtPred :: IrredCt -> PredType
+irredCtPred = ctEvPred . irredCtEvidence
+
+ctIrredCt :: CtIrredReason -> Ct -> IrredCt
+ctIrredCt _ (CIrredCan ir) = ir
+ctIrredCt reason ct = IrredCt { ir_ev = ctEvidence ct
+ , ir_reason = reason }
+
+instance Outputable IrredCt where
+ ppr irred = ppr (CIrredCan irred)
+
+--------------- QCInst --------------
+
data QCInst -- A much simplified version of ClsInst
- -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical
+ -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve
= QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty
-- Always Given
, qci_tvs :: [TcTyVar] -- The tvs
@@ -327,7 +346,7 @@ data QCInst -- A much simplified version of ClsInst
-- (a) qci_pred is a ClassPred
-- (b) this class has superclass(es), and
-- (c) the superclass(es) are not explored yet
- -- Same as cc_pend_sc flag in CDictCan
+ -- Same as di_pend_sc flag in DictCt
-- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver
}
@@ -446,35 +465,40 @@ instance Outputable NotConcreteError where
-- | Used to indicate extra information about why a CIrredCan is irreducible
data CtIrredReason
= IrredShapeReason
- -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)
+ -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)
| NonCanonicalReason CheckTyEqResult
- -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;
+ -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;
-- the 'CheckTyEqResult' states exactly why
| ReprEqReason
- -- ^ an equality that cannot be decomposed because it is representational.
+ -- ^ An equality that cannot be decomposed because it is representational.
-- Example: @a b ~R# Int@.
-- These might still be solved later.
-- INVARIANT: The constraint is a representational equality constraint
| ShapeMismatchReason
- -- ^ a nominal equality that relates two wholly different types,
+ -- ^ A nominal equality that relates two wholly different types,
-- like @Int ~# Bool@ or @a b ~# 3@.
-- INVARIANT: The constraint is a nominal equality constraint
| AbstractTyConReason
- -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@
+ -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@
-- is an abstract type constructor. See Note [Skolem abstract data]
-- in GHC.Core.TyCon.
-- INVARIANT: The constraint is an equality constraint between two TyConApps
+ | PluginReason
+ -- ^ A typechecker plugin returned this in the pluginBadCts field
+ -- of TcPluginProgress
+
instance Outputable CtIrredReason where
ppr IrredShapeReason = text "(irred)"
ppr (NonCanonicalReason cter) = ppr cter
ppr ReprEqReason = text "(repr)"
ppr ShapeMismatchReason = text "(shape)"
ppr AbstractTyConReason = text "(abstc)"
+ ppr PluginReason = text "(plugin)"
-- | Are we sure that more solving will never solve this constraint?
isInsolubleReason :: CtIrredReason -> Bool
@@ -483,6 +507,7 @@ isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter
isInsolubleReason ReprEqReason = False
isInsolubleReason ShapeMismatchReason = True
isInsolubleReason AbstractTyConReason = True
+isInsolubleReason PluginReason = True
------------------------------------------------------------------------------
--
@@ -517,7 +542,7 @@ cteSolubleOccurs = CTEP (bit 3) -- Occurs-check under a type function, or in
-- or in a representational equality; see
-- See Note [Occurs check and representational equality]
-- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs
- -- See also Note [Insoluble occurs check] in GHC.Tc.Errors
+ -- See also Note [Insoluble mis-match] in GHC.Tc.Errors
cteCoercionHole = CTEP (bit 4) -- Coercion hole encountered
cteConcrete = CTEP (bit 5) -- Type variable that can't be made concrete
@@ -631,10 +656,10 @@ Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable
Note [Ct/evidence invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field
-of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan,
- ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct)
-This holds by construction; look at the unique place where CDictCan is
-built (in GHC.Tc.Solver.Canonical).
+of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for DictCt,
+ ctev_pred (di_ev ct) = (di_cls ct) (di_tys ct)
+This holds by construction; look at the unique place where DictCt is
+built (in GHC.Tc.Solver.Dict.canDictNC).
Note [Ct kind invariant]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -683,13 +708,7 @@ Type-level holes have no evidence at all.
-}
mkNonCanonical :: CtEvidence -> Ct
-mkNonCanonical ev = CNonCanonical { cc_ev = ev }
-
-mkNonCanonicalCt :: Ct -> Ct
-mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
-
-mkIrredCt :: CtIrredReason -> CtEvidence -> Ct
-mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason }
+mkNonCanonical ev = CNonCanonical ev
mkGivens :: CtLoc -> [EvId] -> [Ct]
mkGivens loc ev_ids
@@ -700,9 +719,20 @@ mkGivens loc ev_ids
, ctev_loc = loc })
ctEvidence :: Ct -> CtEvidence
-ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
-ctEvidence (CEqCan (EqCt { eq_ev = ev })) = ev
-ctEvidence ct = cc_ev ct
+ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
+ctEvidence (CEqCan (EqCt { eq_ev = ev })) = ev
+ctEvidence (CIrredCan (IrredCt { ir_ev = ev })) = ev
+ctEvidence (CNonCanonical ev) = ev
+ctEvidence (CDictCan (DictCt { di_ev = ev })) = ev
+
+updCtEvidence :: (CtEvidence -> CtEvidence) -> Ct -> Ct
+updCtEvidence upd ct
+ = case ct of
+ CQuantCan qci@(QCI { qci_ev = ev }) -> CQuantCan (qci { qci_ev = upd ev })
+ CEqCan eq@(EqCt { eq_ev = ev }) -> CEqCan (eq { eq_ev = upd ev })
+ CIrredCan ir@(IrredCt { ir_ev = ev }) -> CIrredCan (ir { ir_ev = upd ev })
+ CNonCanonical ev -> CNonCanonical (upd ev)
+ CDictCan di@(DictCt { di_ev = ev }) -> CDictCan (di { di_ev = upd ev })
ctLoc :: Ct -> CtLoc
ctLoc = ctEvLoc . ctEvidence
@@ -758,10 +788,10 @@ instance Outputable Ct where
pp_sort = case ct of
CEqCan {} -> text "CEqCan"
CNonCanonical {} -> text "CNonCanonical"
- CDictCan { cc_pend_sc = psc }
+ CDictCan (DictCt { di_pend_sc = psc })
| psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CDictCan"
- CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason
+ CIrredCan (IrredCt { ir_reason = reason }) -> text "CIrredCan" <> ppr reason
CQuantCan (QCI { qci_pend_sc = psc })
| psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CQuantCan"
@@ -1007,16 +1037,19 @@ isUnsatisfiableCt_maybe t
= Nothing
isPendingScDict :: Ct -> Bool
-isPendingScDict (CDictCan { cc_pend_sc = f }) = pendingFuel f
--- Says whether this is a CDictCan with cc_pend_sc has positive fuel;
+isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct
+isPendingScDict _ = False
+
+isPendingScDictCt :: DictCt -> Bool
+-- Says whether this is a CDictCan with di_pend_sc has positive fuel;
-- i.e. pending un-expanded superclasses
-isPendingScDict _ = False
+isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f
pendingScDict_maybe :: Ct -> Maybe Ct
--- Says whether this is a CDictCan with cc_pend_sc has fuel left,
+-- Says whether this is a CDictCan with di_pend_sc has fuel left,
-- AND if so exhausts the fuel so that they are not expanded again
-pendingScDict_maybe ct@(CDictCan { cc_pend_sc = f })
- | pendingFuel f = Just (ct { cc_pend_sc = doNotExpand })
+pendingScDict_maybe (CDictCan dict@(DictCt { di_pend_sc = f }))
+ | pendingFuel f = Just (CDictCan (dict { di_pend_sc = doNotExpand }))
| otherwise = Nothing
pendingScDict_maybe _ = Nothing
@@ -1039,8 +1072,8 @@ superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })
might_help_ct ct = not (is_ip ct)
- is_ip (CDictCan { cc_class = cls }) = isIPClass cls
- is_ip _ = False
+ is_ip (CDictCan (DictCt { di_cls = cls })) = isIPClass cls
+ is_ip _ = False
getPendingWantedScs :: Cts -> ([Ct], Cts)
-- in the return values [Ct] has original fuel while Cts has fuel exhausted
@@ -1054,7 +1087,7 @@ getPendingWantedScs simples
{- Note [When superclasses help]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-First read Note [The superclass story] in GHC.Tc.Solver.Canonical.
+First read Note [The superclass story] in GHC.Tc.Solver.Dict
We expand superclasses and iterate only if there is at unsolved wanted
for which expansion of superclasses (e.g. from given constraints)
@@ -1176,9 +1209,9 @@ addSimples wc cts
addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
-addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
-addInsols wc cts
- = wc { wc_simple = wc_simple wc `unionBags` cts }
+addInsols :: WantedConstraints -> Bag IrredCt -> WantedConstraints
+addInsols wc insols
+ = wc { wc_simple = wc_simple wc `unionBags` fmap CIrredCan insols }
addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints
addHoles wc holes
@@ -1298,27 +1331,8 @@ insolubleWantedCt ct = insolubleCt ct &&
not (arisesFromGivens ct) &&
not (isWantedWantedFunDepOrigin (ctOrigin ct))
-insolubleEqCt :: Ct -> Bool
--- Returns True of /equality/ constraints
--- that are /definitely/ insoluble
--- It won't detect some definite errors like
--- F a ~ T (F a)
--- where F is a type family, which actually has an occurs check
---
--- The function is tuned for application /after/ constraint solving
--- i.e. assuming canonicalisation has been done
--- E.g. It'll reply True for a ~ [a]
--- but False for [a] ~ a
--- and
--- True for Int ~ F a Int
--- but False for Maybe Int ~ F a Int Int
--- (where F is an arity-1 type function)
-insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason
-insolubleEqCt _ = False
-
--- | Returns True of equality constraints that are definitely insoluble,
--- as well as TypeError constraints.
--- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.
+insolubleIrredCt :: IrredCt -> Bool
+-- Returns True of Irred constraints that are /definitely/ insoluble
--
-- This function is critical for accurate pattern-match overlap warnings.
-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver
@@ -1326,9 +1340,9 @@ insolubleEqCt _ = False
-- Note that this does not traverse through the constraint to find
-- nested custom type errors: it only detects @TypeError msg :: Constraint@,
-- and not e.g. @Eq (TypeError msg)@.
-insolubleCt :: Ct -> Bool
-insolubleCt ct = isTopLevelUserTypeError (ctPred ct) || insolubleEqCt ct
- where
+insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason })
+ = isInsolubleReason reason
+ || isTopLevelUserTypeError (ctEvPred ev)
-- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg"
-- and "Unsatisfiable msg". It deliberately does not detect TypeError
-- nested in a type (e.g. it does not use "containsUserTypeError"), as that
@@ -1345,6 +1359,18 @@ insolubleCt ct = isTopLevelUserTypeError (ctPred ct) || insolubleEqCt ct
-- > Assert 'True _errMsg = ()
-- > Assert _check errMsg = errMsg
+-- | Returns True of constraints that are definitely insoluble,
+-- as well as TypeError constraints.
+-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.
+--
+-- The function is tuned for application /after/ constraint solving
+-- i.e. assuming canonicalisation has been done
+-- That's why it looks only for IrredCt; all insoluble constraints
+-- are put into CIrredCan
+insolubleCt :: Ct -> Bool
+insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct
+insolubleCt _ = False
+
-- | Does this hole represent an "out of scope" error?
-- See Note [Insoluble holes]
isOutOfScopeHole :: Hole -> Bool
@@ -1483,7 +1509,7 @@ data ImplicStatus
{ ics_dead :: [EvVar] } -- Subset of ic_given that are not needed
-- See Note [Tracking redundant constraints] in GHC.Tc.Solver
- | IC_Insoluble -- At least one insoluble constraint in the tree
+ | IC_Insoluble -- At least one insoluble Wanted constraint in the tree
| IC_BadTelescope -- Solved, but the skolems in the telescope are out of
-- dependency order. See Note [Checking telescopes]
@@ -2148,12 +2174,16 @@ eqCtFlavourRole :: EqCt -> CtFlavourRole
eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel })
= (ctEvFlavour ev, eq_rel)
+dictCtFlavourRole :: DictCt -> CtFlavourRole
+dictCtFlavourRole (DictCt { di_ev = ev })
+ = (ctEvFlavour ev, NomEq)
+
-- | Extract the flavour and role from a 'Ct'
ctFlavourRole :: Ct -> CtFlavourRole
-- Uses short-cuts to role for special cases
-ctFlavourRole (CDictCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq)
-ctFlavourRole (CEqCan eq_ct) = eqCtFlavourRole eq_ct
-ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct)
+ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct
+ctFlavourRole (CEqCan eq_ct) = eqCtFlavourRole eq_ct
+ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct)
{- Note [eqCanRewrite]
~~~~~~~~~~~~~~~~~~~~~~
@@ -2230,8 +2260,9 @@ because only equalities (evidenced by coercion holes) are used for rewriting;
other (dictionary) constraints cannot ever rewrite. The rewriter (in
e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet,
consisting of the evidence (a CoercionHole) for any Wanted equalities used in
-rewriting. Then rewriteEvidence and rewriteEqEvidence (in GHC.Tc.Solver.Canonical)
-add this RewriterSet to the rewritten constraint's arewriter set.
+rewriting. Then GHC.Tc.Solver.Solve.rewriteEvidence and
+GHC.Tc.Solver.Equality.rewriteEqEvidence add this RewriterSet to the rewritten
+constraint's rewriter set.
Note [Prioritise Wanteds with empty RewriterSet]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index 4216613c4a58..81266433f117 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -661,7 +661,7 @@ important) are solved in three steps:
1. Explicit, user-written occurrences of `?stk :: CallStack`
which have IPOccOrigin, are solved directly from the given IP,
- just like a regular IP; see GHC.Tc.Solver.Interact.interactDict.
+ just like a regular IP; see GHC.Tc.Solver.Dict.tryInertDicts.
For example, the occurrence of `?stk` in
@@ -691,7 +691,7 @@ important) are solved in three steps:
[W] d1 : IP "stk" CallStack
with CtOrigin = OccurrenceOf "foo"
- * We /solve/ this constraint, in GHC.Tc.Solver.Canonical.canClassNC
+ * We /solve/ this constraint, in GHC.Tc.Solver.Dict.canDictNC
by emitting a NEW Wanted
[W] d2 :: IP "stk" CallStack
with CtOrigin = IPOccOrigin
@@ -777,7 +777,7 @@ Important Details:
- When we emit a new wanted CallStack from rule (2) we set its origin to
`IPOccOrigin ip_name` instead of the original `OccurrenceOf func`
- (see GHC.Tc.Solver.Interact.interactDict).
+ (see GHC.Tc.Solver.Dict.tryInertDicts).
This is a bit shady, but is how we ensure that the new wanted is
solved like a regular IP.
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 62df4af981e4..7bccec419830 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -480,7 +480,7 @@ data CtOrigin
ScDepth -- ^ The number of superclass selections necessary to
-- get this constraint; see Note [Replacement vs keeping]
- -- in GHC.Tc.Solver.Interact
+ -- in GHC.Tc.Solver.Dict
Bool -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds
-- i.e. ones with (ScOrigin _ NakedSc)
@@ -608,7 +608,7 @@ data CtOrigin
| CycleBreakerOrigin
CtOrigin -- origin of the original constraint
- -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical
+ -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality
| FRROrigin
FixedRuntimeRepOrigin
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 4d93bf1aecb0..849466b16497 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -209,24 +209,25 @@ check_inst sig_inst@(ClsInst { is_dfun = dfun_id }) = do
-- TODO: This could be very well generalized to support instance
-- declarations in boot files.
tcg_env <- getGblEnv
+ lcl_env <- getLclEnv
+
-- NB: Have to tug on the interface, not necessarily
-- tugged... but it didn't work?
mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
-- Based off of 'simplifyDeriv'
- let origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
(skol_info, tvs_skols, inst_theta, cls, inst_tys) <- tcSkolDFunType (idType dfun_id)
(tclvl,cts) <- pushTcLevelM $ do
+ given_ids <- mapM newEvVar inst_theta
+ let given_loc = mkGivenLoc topTcLevel skol_info lcl_env
+ givens = [ CtGiven { ctev_pred = idType given_id
+ -- Doesn't matter, make something up
+ , ctev_evar = given_id
+ , ctev_loc = given_loc }
+ | given_id <- given_ids ]
+ origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys)
- givens <- forM inst_theta $ \given -> do
- loc <- getCtLocM origin (Just TypeLevel)
- new_ev <- newEvVar given
- return CtGiven { ctev_pred = given
- -- Doesn't matter, make something up
- , ctev_evar = new_ev
- , ctev_loc = loc
- }
- return $ wanted : givens
+ return (wanted : givens)
unsolved <- simplifyWantedsTcM cts
(implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 534e966b949e..ca31447dbf1c 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -105,7 +105,7 @@ module GHC.Tc.Utils.Monad(
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
- emitImplication, emitImplications, emitInsoluble,
+ emitImplication, emitImplications,
emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
@@ -1828,12 +1828,6 @@ emitImplications ct
do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` ct) }
-emitInsoluble :: Ct -> TcM ()
-emitInsoluble ct
- = do { traceTc "emitInsoluble" (ppr ct)
- ; lie_var <- getConstraintVar
- ; updTcRef lie_var (`addInsols` unitBag ct) }
-
emitDelayedErrors :: Bag DelayedError -> TcM ()
emitDelayedErrors errs
= do { traceTc "emitDelayedErrors" (ppr errs)
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 7db80cfccb4b..0650ba122c69 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -771,7 +771,7 @@ Proposal 29).
newMetaTyVarName :: FastString -> TcM Name
-- Makes a /System/ Name, which is eagerly eliminated by
-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and
--- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2)
+-- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2)
newMetaTyVarName str
= newSysName (mkTyVarOccFS str)
@@ -873,7 +873,7 @@ cloneAnonMetaTyVar info tv kind
; return tyvar }
-- Make a new CycleBreakerTv. See Note [Type equality cycles]
--- in GHC.Tc.Solver.Canonical.
+-- in GHC.Tc.Solver.Equality
newCycleBreakerTyVar :: TcKind -> TcM TcTyVar
newCycleBreakerTyVar kind
= do { details <- newMetaDetails CycleBreakerTv
@@ -988,7 +988,7 @@ writeMetaTyVarRef tyvar ref ty
-- Everything from here on only happens if DEBUG is on
-- Need to zonk 'ty' because we may only recently have promoted
- -- its free meta-tyvars (see Solver.Interact.tryToSolveByUnification)
+ -- its free meta-tyvars (see GHC.Tc.Utils.Unify.checkPromoteFreeVars)
| otherwise
= do { meta_details <- readMutVar ref;
-- Zonk kinds to allow the error check to work
@@ -2448,24 +2448,24 @@ will be canonicalised again, so there is little benefit in keeping the
CEqCan structure.
NB: Constraints are always rewritten etc by the canonicaliser in
-@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that
-are actually in the inert set carry all the guarantees. So it is okay if zonkCt
-creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced.
--}
+GHC.Tc.Solver.Solve.solveCt even if they come in as CDictCan. Only canonical
+constraints that are actually in the inert set carry all the guarantees. So it
+is okay if zonkCt creates e.g. a CDictCan where the cc_tyars are /not/ fully
+reduced. -}
zonkCt :: Ct -> TcM Ct
-- See Note [zonkCt behaviour]
-zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
+zonkCt (CDictCan dict@(DictCt { di_ev = ev, di_tys = args }))
= do { ev' <- zonkCtEvidence ev
; args' <- mapM zonkTcType args
- ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+ ; return (CDictCan (dict { di_ev = ev', di_tys = args' })) }
zonkCt (CEqCan (EqCt { eq_ev = ev }))
= mkNonCanonical <$> zonkCtEvidence ev
-zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag
+zonkCt (CIrredCan ir@(IrredCt { ir_ev = ev })) -- Preserve the cc_reason flag
= do { ev' <- zonkCtEvidence ev
- ; return (ct { cc_ev = ev' }) }
+ ; return (CIrredCan (ir { ir_ev = ev' })) }
zonkCt ct
= do { fl' <- zonkCtEvidence (ctEvidence ct)
@@ -2694,7 +2694,7 @@ zonkTidyFRRInfos = go []
----------------
tidyCt :: TidyEnv -> Ct -> Ct
-- Used only in error reporting
-tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }
+tidyCt env ct = updCtEvidence (tidyCtEvidence env) ct
tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evar field because we don't
@@ -2792,16 +2792,19 @@ naughtyQuantification orig_ty tv escapees
zonkCtRewriterSet :: Ct -> TcM Ct
zonkCtRewriterSet ct
- | isGiven ev = return ct
+ | isGivenCt ct
+ = return ct
| otherwise
= case ct of
- CQuantCan {} -> return ct
- CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev
- ; return (CEqCan (eq { eq_ev = ev' })) }
- _ -> do { ev' <- zonkCtEvRewriterSet ev
- ; return (ct { cc_ev = ev' }) }
- where
- ev = ctEvidence ct
+ CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev
+ ; return (CEqCan (eq { eq_ev = ev' })) }
+ CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev
+ ; return (CIrredCan (ir { ir_ev = ev' })) }
+ CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev
+ ; return (CDictCan (di { di_ev = ev' })) }
+ CQuantCan {} -> return ct
+ CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev
+ ; return (CNonCanonical ev') }
zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence
zonkCtEvRewriterSet ev@(CtGiven {})
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 00f6a73532c2..27d0610c045a 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -161,8 +161,8 @@ module GHC.Tc.Utils.TcType (
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
- isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,
- mkClassPred,
+ isClassPred, isEqPrimPred, isIPLikePred, isEqPred,
+ isEqualityClass, mkClassPred,
tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isFixedRuntimeRepKind,
isVisiblePiTyBinder, isInvisiblePiTyBinder,
@@ -668,7 +668,7 @@ data MetaInfo
| CycleBreakerTv -- Used to fix occurs-check problems in Givens
-- See Note [Type equality cycles] in
- -- GHC.Tc.Solver.Canonical
+ -- GHC.Tc.Solver.Equality
| ConcreteTv ConcreteTvOrigin
-- ^ A unification variable that can only be unified
@@ -1856,7 +1856,7 @@ Then
Notice that in the recursive-superclass case we include C again at
the end of the chain. One could exclude C in this case, but
the code is more awkward and there seems no good reason to do so.
-(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/
+(However C.f. GHC.Tc.Solver.Dict.mk_strict_superclasses, which /does/
appear to do so.)
The algorithm is expand( so_far, pred ):
@@ -2538,11 +2538,10 @@ isTerminatingClass cls
= isIPClass cls -- Implicit parameter constraints always terminate because
-- there are no instances for them --- they are only solved
-- by "local instances" in expressions
- || isEqPredClass cls
+ || isEqualityClass cls
|| cls `hasKey` typeableClassKey
-- Typeable constraints are bigger than they appear due
-- to kind polymorphism, but we can never get instance divergence this way
- || cls `hasKey` coercibleTyConKey
|| cls `hasKey` unsatisfiableClassNameKey
allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 428eba5d69bf..1f2db5b2c1d2 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -2203,7 +2203,7 @@ uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2
Just uref -> updTcRef uref (tv1 :)
; return (mkNomReflCo ty2) } -- Unification is always Nominal
- else -- The kinds don't match yet, so give up defer instead.
+ else -- The kinds don't match yet, so defer instead.
do { writeTcRef def_eq_ref def_eqs
-- Since we are discarding co_k, also discard any constraints
-- emitted by kind unification; they are just useless clutter.
@@ -2366,7 +2366,7 @@ Needless to say, all there are wrinkles:
* In the constraint solver, we track where Given equalities occur
and use that to guard unification in
- GHC.Tc.Solver.Canonical.touchabilityAndShapeTest. More details in
+ GHC.Tc.Utils.Unify.touchabilityAndShapeTest. More details in
Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
Historical note: in the olden days (pre 2021) the constraint solver
@@ -2387,7 +2387,7 @@ This is a surprisingly tricky question!
The question is answered by swapOverTyVars, which is used
- in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1
- - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2
+ - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2
First note: only swap if you have to!
See Note [Avoid unnecessary swaps]
@@ -2529,31 +2529,6 @@ better in practice.
Revisited in Nov '20, along with removing flattening variables. Problem
is still present, and the solution is still the same.
-Note [Type synonyms and the occur check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally speaking we try to update a variable with type synonyms not
-expanded, which improves later error messages, unless looking
-inside a type synonym may help resolve a spurious occurs check
-error. Consider:
- type A a = ()
-
- f :: (A a -> a -> ()) -> ()
- f = \ _ -> ()
-
- x :: ()
- x = f (\ x p -> p x)
-
-We will eventually get a constraint of the form t ~ A t. The ok function above will
-properly expand the type (A t) to just (), which is ok to be unified with t. If we had
-unified with the original type A t, we would lead the type checker into an infinite loop.
-
-Hence, if the occurs check fails for a type synonym application, then (and *only* then),
-the ok function expands the synonym to detect opportunities for occurs check success using
-the underlying definition of the type synonym.
-
-The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact,
-function @occ_check_ok@.
-
Note [Non-TcTyVars in GHC.Tc.Utils.Unify]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because the same code is now shared between unifying types and unifying
@@ -3272,7 +3247,7 @@ promote_meta_tyvar info dest_lvl occ_tv
touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool
-- This is the key test for untouchability:
-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
--- and Note [Solve by unification] in GHC.Tc.Solver.Interact
+-- and Note [Solve by unification] in GHC.Tc.Solver.Equality
-- True <=> touchability and shape are OK
touchabilityAndShapeTest given_eq_lvl tv rhs
| MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 59f18e5d74a3..c2fe7f7fb172 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -233,19 +233,20 @@ so we can take their type variables into account as part of the
checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity ctxt ty
| wantAmbiguityCheck ctxt
- = do { traceTc "Ambiguity check for" (ppr ty)
+ = do { traceTc "Ambiguity check for {" (ppr ty)
-- Solve the constraints eagerly because an ambiguous type
-- can cause a cascade of further errors. Since the free
-- tyvars are skolemised, we can safely use tcSimplifyTop
; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
- ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
- captureConstraints $
- tcSubTypeAmbiguity ctxt ty ty
- -- See Note [Ambiguity check and deep subsumption]
- -- in GHC.Tc.Utils.Unify
- ; simplifyAmbiguityCheck ty wanted
+ ; unless allow_ambiguous $
+ do { (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
+ captureConstraints $
+ tcSubTypeAmbiguity ctxt ty ty
+ -- See Note [Ambiguity check and deep subsumption]
+ -- in GHC.Tc.Utils.Unify
+ ; simplifyAmbiguityCheck ty wanted }
- ; traceTc "Done ambiguity check for" (ppr ty) }
+ ; traceTc "} Done ambiguity check for" (ppr ty) }
| otherwise
= return ()
@@ -1230,7 +1231,7 @@ e.g. module A where
check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
-> PredType -> Class -> [TcType] -> TcM ()
check_class_pred env dflags ctxt pred cls tys
- | isEqPredClass cls -- (~) and (~~) are classified as classes,
+ | isEqualityClass cls -- (~) and (~~) and Coercible are classified as classes,
-- but here we want to treat them as equalities
= -- Equational constraints are valid in all contexts, and
-- we do not need to check e.g. for FlexibleContexts here, so just do nothing
@@ -1301,9 +1302,9 @@ checkSimplifiableClassConstraint env dflags ctxt cls tys
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A type signature like
f :: Eq [(a,b)] => a -> b
-is very fragile, for reasons described at length in GHC.Tc.Solver.Interact
+is very fragile, for reasons described at length in GHC.Tc.Solver.Dict
Note [Instance and Given overlap]. As that Note discusses, for the
-most part the clever stuff in GHC.Tc.Solver.Interact means that we don't use a
+most part the clever stuff in GHC.Tc.Solver.Dict means that we don't use a
top-level instance if a local Given might fire, so there is no
fragility. But if we /infer/ the type of a local let-binding, things
can go wrong (#11948 is an example, discussed in the Note).
@@ -1315,7 +1316,7 @@ class constraints.
The warning only fires if the constraint in the signature
matches the top-level instances in only one way, and with no
unifiers -- that is, under the same circumstances that
-GHC.Tc.Solver.Interact.matchInstEnv fires an interaction with the top
+GHC.Tc.Instance.Class.matchInstEnv fires an interaction with the top
level instances. For example (#13526), consider
instance {-# OVERLAPPABLE #-} Eq (T a) where ...
@@ -1696,7 +1697,7 @@ the middle:
Note [Validity checking of HasField instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The HasField class has magic constraint solving behaviour (see Note
-[HasField instances] in GHC.Tc.Solver.Interact). However, we permit users to
+[HasField instances] in GHC.Tc.Instance.Class). However, we permit users to
declare their own instances, provided they do not clash with the
built-in behaviour. In particular, we forbid:
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 49c0b1025139..8fc1467527a7 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -906,6 +906,9 @@ class Outputable a where
-- There's no Outputable for Char; it's too easy to use Outputable
-- on String and have ppr "hello" rendered as "h,e,l,l,o".
+instance Outputable Void where
+ ppr _ = text "<<Void>>"
+
instance Outputable Bool where
ppr True = text "True"
ppr False = text "False"
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 684e99c8158c..65528be6b437 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -732,10 +732,10 @@ Library
GHC.Tc.Module
GHC.Tc.Plugin
GHC.Tc.Solver
- GHC.Tc.Solver.Canonical
GHC.Tc.Solver.Rewrite
GHC.Tc.Solver.InertSet
- GHC.Tc.Solver.Interact
+ GHC.Tc.Solver.Solve
+ GHC.Tc.Solver.Irred
GHC.Tc.Solver.Equality
GHC.Tc.Solver.Dict
GHC.Tc.Solver.Monad
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index ea3a3a7be6d4..3818548e85f1 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -112,6 +112,13 @@ Compiler
This allows errors to be reported when users use the instance, even when
type errors are being deferred.
+- GHC is now deals "insoluble Givens" in a consistent way. For example: ::
+
+ k :: (Int ~ Bool) => Int -> Bool
+ k x = x
+
+ GHC used to accept the contradictory ``Int~Bool`` in the type signature, but reject the ``Int~Bool`` constraint that arises from typechecking the definition itself. Now it accepts both. More details in `GHC ticket #23413 <https://gitlab.haskell.org/ghc/ghc/-/issues/23413>`_, which gives examples of the previous inconsistency. GHC now implements the "PermissivePlan" described in that ticket.
+
GHCi
~~~~
diff --git a/docs/users_guide/exts/ambiguous_types.rst b/docs/users_guide/exts/ambiguous_types.rst
index 265b0e5062b5..3c59beed8087 100644
--- a/docs/users_guide/exts/ambiguous_types.rst
+++ b/docs/users_guide/exts/ambiguous_types.rst
@@ -107,11 +107,7 @@ the :extension:`TypeApplications` extension to specify the types. For example: :
Here ``a`` is ambiguous in the definition of ``D`` but later specified
to be `Int` using type applications.
-:extension:`AllowAmbiguousTypes` allows you to switch off the ambiguity check.
-However, even with ambiguity checking switched off, GHC will complain about a
-function that can *never* be called, such as this one: ::
-
- f :: (Int ~ Bool) => a -> a
+:extension:`AllowAmbiguousTypes` allows you to switch off the ambiguity check altogether.
Sometimes :extension:`AllowAmbiguousTypes` does not mix well with :extension:`RankNTypes`.
For example: ::
diff --git a/testsuite/tests/gadt/T3651.hs b/testsuite/tests/gadt/T3651.hs
index 9f671905c81f..a79f5825f06a 100644
--- a/testsuite/tests/gadt/T3651.hs
+++ b/testsuite/tests/gadt/T3651.hs
@@ -10,6 +10,19 @@ data Z a where
unsafe1 :: Z a -> Z a -> a
unsafe1 B U = ()
+{- For unsafe1 we get:
+
+ [G] a ~ () => [G] a ~ Bool => [W] Bool ~ a
+
+By the time we get to the Wanted we have:
+ inert: [G] a ~# Bool (CEqCan)
+ [G] () ~# Bool (CIrredCan)
+ work: [W] Bool ~ a
+
+We rewrite with the CEqCan to get [W] Bool ~ (); we reduce that
+to [W] Bool ~# (). That is insoluble, but we solve it from [G] () ~# Bool
+-}
+
unsafe2 :: a ~ b => Z b -> Z a -> a
unsafe2 B U = ()
diff --git a/testsuite/tests/gadt/T3651.stderr b/testsuite/tests/gadt/T3651.stderr
index b4c7a2e65d37..2c42e1458637 100644
--- a/testsuite/tests/gadt/T3651.stderr
+++ b/testsuite/tests/gadt/T3651.stderr
@@ -1,14 +1,33 @@
-T3651.hs:11:15: error: [GHC-83865]
- • Couldn't match type ‘()’ with ‘Bool’
- Expected: a
- Actual: ()
- • In the expression: ()
+T3651.hs:11:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘unsafe1’: unsafe1 B U = ...
+
+T3651.hs:11:11: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+ • Inaccessible code in
+ a pattern with constructor: U :: Z (), in an equation for ‘unsafe1’
+ Couldn't match type ‘Bool’ with ‘()’
+ • In the pattern: U
In an equation for ‘unsafe1’: unsafe1 B U = ()
-T3651.hs:14:15: error: [GHC-83865]
- • Couldn't match type ‘()’ with ‘Bool’
- Expected: a
- Actual: ()
- • In the expression: ()
+T3651.hs:27:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘unsafe2’: unsafe2 B U = ...
+
+T3651.hs:27:11: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+ • Inaccessible code in
+ a pattern with constructor: U :: Z (), in an equation for ‘unsafe2’
+ Couldn't match type ‘Bool’ with ‘()’
+ • In the pattern: U
In an equation for ‘unsafe2’: unsafe2 B U = ()
+
+T3651.hs:30:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘unsafe3’: unsafe3 B U = ...
+
+T3651.hs:30:11: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+ • Inaccessible code in
+ a pattern with constructor: U :: Z (), in an equation for ‘unsafe3’
+ Couldn't match type ‘Bool’ with ‘()’
+ • In the pattern: U
+ In an equation for ‘unsafe3’: unsafe3 B U = True
diff --git a/testsuite/tests/gadt/T7558.hs b/testsuite/tests/gadt/T7558.hs
index 129704f95523..11becfa95ffc 100644
--- a/testsuite/tests/gadt/T7558.hs
+++ b/testsuite/tests/gadt/T7558.hs
@@ -6,3 +6,11 @@ data T a b where
f :: T a a -> Bool
f (MkT x y) = [x,y] `seq` True
+
+{- We get
+
+[G] a ~ Maybe a
+[W] a ~ Maybe a
+
+We can solve the Wanted from the Given
+-}
\ No newline at end of file
diff --git a/testsuite/tests/gadt/T7558.stderr b/testsuite/tests/gadt/T7558.stderr
index 600283670f16..bb8d1dfd53a6 100644
--- a/testsuite/tests/gadt/T7558.stderr
+++ b/testsuite/tests/gadt/T7558.stderr
@@ -1,14 +1,19 @@
-T7558.hs:8:18: error: [GHC-25897]
- • Couldn't match expected type ‘a’ with actual type ‘Maybe a’
+T7558.hs:8:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘f’: f (MkT x y) = ...
+
+T7558.hs:8:4: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+ • Inaccessible code in
+ a pattern with constructor:
+ MkT :: forall a b. (a ~ Maybe b) => a -> Maybe b -> T a b,
+ in an equation for ‘f’
+ Couldn't match type ‘a’ with ‘Maybe a’
‘a’ is a rigid type variable bound by
the type signature for:
f :: forall a. T a a -> Bool
at T7558.hs:7:1-18
- • In the expression: y
- In the first argument of ‘seq’, namely ‘[x, y]’
- In the expression: [x, y] `seq` True
+ • In the pattern: MkT x y
+ In an equation for ‘f’: f (MkT x y) = [x, y] `seq` True
• Relevant bindings include
- y :: Maybe a (bound at T7558.hs:8:10)
- x :: a (bound at T7558.hs:8:8)
f :: T a a -> Bool (bound at T7558.hs:8:1)
diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T
index b64681267d66..da7b03e25f05 100644
--- a/testsuite/tests/gadt/all.T
+++ b/testsuite/tests/gadt/all.T
@@ -93,7 +93,7 @@ test('T2151', normal, compile, [''])
test('T3013', normal, compile, [''])
test('T3163', normal, compile_fail, [''])
test('gadt25', normal, compile, [''])
-test('T3651', normal, compile_fail, [''])
+test('T3651', normal, compile, [''])
test('T3638', normal, compile, [''])
test('gadtSyntax001', normal, compile, [''])
@@ -110,7 +110,7 @@ test('T7293', normal, compile_fail, ['-Werror'])
test('T7294', normal, compile, [''])
test('T7321', [], makefile_test, [])
test('T7974', normal, compile, [''])
-test('T7558', normal, compile_fail, [''])
+test('T7558', normal, compile, [''])
test('T9380', normal, compile_and_run, [''])
test('T12087', normal, compile_fail, [''])
test('T12468', normal, compile_fail, [''])
diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr
index e05dccbd0866..f0698cf8cc7c 100644
--- a/testsuite/tests/ghci/scripts/Defer02.stderr
+++ b/testsuite/tests/ghci/scripts/Defer02.stderr
@@ -1,5 +1,5 @@
-Defer01.hs:11:40: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:10:40: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match type ‘Char’ with ‘[Char]’
Expected: String
Actual: Char
@@ -7,16 +7,16 @@ Defer01.hs:11:40: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
In the second argument of ‘(>>)’, namely ‘putStr ','’
In the expression: putStr "Hello World" >> putStr ','
-Defer01.hs:14:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:13:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match expected type ‘Int’ with actual type ‘Char’
• In the expression: 'p'
In an equation for ‘a’: a = 'p'
-Defer01.hs:25:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+Defer01.hs:24:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
Pattern match has inaccessible right hand side
In an equation for ‘c’: c (C2 x) = ...
-Defer01.hs:25:4: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+Defer01.hs:24:4: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
• Inaccessible code in
a pattern with constructor: C2 :: Bool -> C Bool,
in an equation for ‘c’
@@ -24,49 +24,44 @@ Defer01.hs:25:4: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
• In the pattern: C2 x
In an equation for ‘c’: c (C2 x) = True
-Defer01.hs:31:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:30:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match expected type ‘Char -> t’ with actual type ‘Char’
• The function ‘e’ is applied to one value argument,
but its type ‘Char’ has none
In the expression: e 'q'
In an equation for ‘f’: f = e 'q'
- • Relevant bindings include f :: t (bound at Defer01.hs:31:1)
+ • Relevant bindings include f :: t (bound at Defer01.hs:30:1)
-Defer01.hs:34:8: warning: [GHC-25897] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:33:8: warning: [GHC-25897] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match expected type ‘Char’ with actual type ‘a’
‘a’ is a rigid type variable bound by
the type signature for:
h :: forall a. a -> (Char, Char)
- at Defer01.hs:33:1-21
+ at Defer01.hs:32:1-21
• In the expression: x
In the expression: (x, 'c')
In an equation for ‘h’: h x = (x, 'c')
• Relevant bindings include
- x :: a (bound at Defer01.hs:34:3)
- h :: a -> (Char, Char) (bound at Defer01.hs:34:1)
+ x :: a (bound at Defer01.hs:33:3)
+ h :: a -> (Char, Char) (bound at Defer01.hs:33:1)
-Defer01.hs:39:17: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:38:17: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match expected type ‘Bool’ with actual type ‘T a’
• In the first argument of ‘not’, namely ‘(K a)’
In the first argument of ‘seq’, namely ‘(not (K a))’
In the expression: seq (not (K a)) ()
• Relevant bindings include
- a :: a (bound at Defer01.hs:39:3)
- i :: a -> () (bound at Defer01.hs:39:1)
+ a :: a (bound at Defer01.hs:38:3)
+ i :: a -> () (bound at Defer01.hs:38:1)
-Defer01.hs:47:7: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match expected type ‘Bool’ with actual type ‘Int’
- • In the expression: x
- In an equation for ‘k’: k x = x
-
-Defer01.hs:50:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+Defer01.hs:49:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match expected type: IO a0
with actual type: Char -> IO ()
• Probable cause: ‘putChar’ is applied to too few arguments
In the first argument of ‘(>>)’, namely ‘putChar’
In the expression: putChar >> putChar 'p'
In an equation for ‘l’: l = putChar >> putChar 'p'
-*** Exception: Defer01.hs:11:40: error: [GHC-83865]
+*** Exception: Defer01.hs:10:40: error: [GHC-83865]
• Couldn't match type ‘Char’ with ‘[Char]’
Expected: String
Actual: Char
@@ -74,12 +69,12 @@ Defer01.hs:50:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
In the second argument of ‘(>>)’, namely ‘putStr ','’
In the expression: putStr "Hello World" >> putStr ','
(deferred type error)
-*** Exception: Defer01.hs:14:5: error: [GHC-83865]
+*** Exception: Defer01.hs:13:5: error: [GHC-83865]
• Couldn't match expected type ‘Int’ with actual type ‘Char’
• In the expression: 'p'
In an equation for ‘a’: a = 'p'
(deferred type error)
-*** Exception: Defer01.hs:18:9: error: [GHC-39999]
+*** Exception: Defer01.hs:17:9: error: [GHC-39999]
• No instance for ‘Eq B’ arising from a use of ‘==’
• In the expression: x == x
In an equation for ‘b’: b x = x == x
@@ -92,43 +87,43 @@ Defer01.hs:50:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• In the first argument of ‘c’, namely ‘(C2 True)’
In the first argument of ‘print’, namely ‘(c (C2 True))’
In the expression: print (c (C2 True))
-*** Exception: Defer01.hs:28:5: error: [GHC-39999]
+*** Exception: Defer01.hs:27:5: error: [GHC-39999]
• No instance for ‘Num (a -> a)’ arising from the literal ‘1’
(maybe you haven't applied a function to enough arguments?)
• In the expression: 1
In an equation for ‘d’: d = 1
(deferred type error)
-*** Exception: Defer01.hs:31:5: error: [GHC-83865]
+*** Exception: Defer01.hs:30:5: error: [GHC-83865]
• Couldn't match expected type ‘Char -> t’ with actual type ‘Char’
• The function ‘e’ is applied to one value argument,
but its type ‘Char’ has none
In the expression: e 'q'
In an equation for ‘f’: f = e 'q'
- • Relevant bindings include f :: t (bound at Defer01.hs:31:1)
+ • Relevant bindings include f :: t (bound at Defer01.hs:30:1)
(deferred type error)
-*** Exception: Defer01.hs:34:8: error: [GHC-25897]
+*** Exception: Defer01.hs:33:8: error: [GHC-25897]
• Couldn't match expected type ‘Char’ with actual type ‘a’
‘a’ is a rigid type variable bound by
the type signature for:
h :: forall a. a -> (Char, Char)
- at Defer01.hs:33:1-21
+ at Defer01.hs:32:1-21
• In the expression: x
In the expression: (x, 'c')
In an equation for ‘h’: h x = (x, 'c')
• Relevant bindings include
- x :: a (bound at Defer01.hs:34:3)
- h :: a -> (Char, Char) (bound at Defer01.hs:34:1)
+ x :: a (bound at Defer01.hs:33:3)
+ h :: a -> (Char, Char) (bound at Defer01.hs:33:1)
(deferred type error)
-*** Exception: Defer01.hs:39:17: error: [GHC-83865]
+*** Exception: Defer01.hs:38:17: error: [GHC-83865]
• Couldn't match expected type ‘Bool’ with actual type ‘T a’
• In the first argument of ‘not’, namely ‘(K a)’
In the first argument of ‘seq’, namely ‘(not (K a))’
In the expression: seq (not (K a)) ()
• Relevant bindings include
- a :: a (bound at Defer01.hs:39:3)
- i :: a -> () (bound at Defer01.hs:39:1)
+ a :: a (bound at Defer01.hs:38:3)
+ i :: a -> () (bound at Defer01.hs:38:1)
(deferred type error)
-*** Exception: Defer01.hs:43:5: error: [GHC-39999]
+*** Exception: Defer01.hs:42:5: error: [GHC-39999]
• No instance for ‘MyClass a1’ arising from a use of ‘myOp’
• In the expression: myOp 23
In an equation for ‘j’: j = myOp 23
@@ -139,7 +134,7 @@ Defer01.hs:50:5: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
• In the first argument of ‘print’, namely ‘(k 2)’
In the expression: print (k 2)
In an equation for ‘it’: it = print (k 2)
-*** Exception: Defer01.hs:50:5: error: [GHC-83865]
+*** Exception: Defer01.hs:49:5: error: [GHC-83865]
• Couldn't match expected type: IO a0
with actual type: Char -> IO ()
• Probable cause: ‘putChar’ is applied to too few arguments
diff --git a/testsuite/tests/indexed-types/should_compile/T18875.hs b/testsuite/tests/indexed-types/should_compile/T18875.hs
index f3874005b908..0125f81d2e9c 100644
--- a/testsuite/tests/indexed-types/should_compile/T18875.hs
+++ b/testsuite/tests/indexed-types/should_compile/T18875.hs
@@ -2,7 +2,7 @@
module T18875 where
--- This exercises Note [Type equality cycles] in GHC.Tc.Solver.Canonical
+-- This exercises Note [Type equality cycles] in GHC.Tc.Solver.Equality
type family G a b where
G (Maybe c) d = d
diff --git a/testsuite/tests/indexed-types/should_fail/T13674.stderr b/testsuite/tests/indexed-types/should_fail/T13674.stderr
index 9ab9fc795f0e..7414ecf5f652 100644
--- a/testsuite/tests/indexed-types/should_fail/T13674.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T13674.stderr
@@ -17,20 +17,3 @@ T13674.hs:56:21: error: [GHC-25897]
y :: GF m (bound at T13674.hs:56:17)
x :: GF m (bound at T13674.hs:56:6)
bar :: GF m -> GF m -> GF m (bound at T13674.hs:56:1)
-
-T13674.hs:56:31: error: [GHC-25897]
- • Couldn't match type ‘m’ with ‘Lcm m m’
- Expected: GF m
- Actual: GF (Lcm m m)
- ‘m’ is a rigid type variable bound by
- the type signature for:
- bar :: forall (m :: Nat). KnownNat m => GF m -> GF m -> GF m
- at T13674.hs:55:1-44
- • In the first argument of ‘(\\)’, namely ‘foo y x’
- In the first argument of ‘(\\)’, namely ‘foo y x \\ lcmNat @m @m’
- In the second argument of ‘(-)’, namely
- ‘foo y x \\ lcmNat @m @m \\ Sub @() (lcmIsIdempotent @m)’
- • Relevant bindings include
- y :: GF m (bound at T13674.hs:56:17)
- x :: GF m (bound at T13674.hs:56:6)
- bar :: GF m -> GF m -> GF m (bound at T13674.hs:56:1)
diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout
index a269670e436d..0b078fd00c75 100644
--- a/testsuite/tests/linters/notes.stdout
+++ b/testsuite/tests/linters/notes.stdout
@@ -57,10 +57,7 @@ ref testsuite/tests/perf/should_run/all.T:8:6: Note [Solving from instanc
ref testsuite/tests/polykinds/CuskFam.hs:16:11: Note [Unifying implicit CUSK variables]
ref testsuite/tests/simplCore/should_compile/T5776.hs:16:7: Note [Simplifying RULE lhs constraints]
ref testsuite/tests/simplCore/should_compile/simpl018.hs:3:7: Note [Float coercions]
-ref testsuite/tests/typecheck/should_compile/CbvOverlap.hs:5:26: Note [Type variable cycles in Givens]
-ref testsuite/tests/typecheck/should_compile/Improvement.hs:10:12: Note [No reduction for Derived class constraints]
ref testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs:7:7: Note [When does an implication have given equalities?]
-ref testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs:21:43: Note [Type variable cycles in Givens]
ref testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs:4:6: Note [When does an implication have given equalities?]
ref testsuite/tests/typecheck/should_compile/T9117.hs:3:12: Note [Order of Coercible Instances]
ref testsuite/tests/typecheck/should_compile/tc200.hs:5:7: Note [Multiple instantiation]
diff --git a/testsuite/tests/pmcheck/should_compile/T12957a.stderr b/testsuite/tests/pmcheck/should_compile/T12957a.stderr
index 318463d71384..ba301f227e0b 100644
--- a/testsuite/tests/pmcheck/should_compile/T12957a.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T12957a.stderr
@@ -11,15 +11,3 @@ T12957a.hs:25:35: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
In a record update at field ‘sFields’,
with type constructor ‘S’
and data constructor ‘S’.
-
-T12957a.hs:25:35: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘B’ with ‘A’
- Expected: Fields A
- Actual: Fields B
- • In a record update at field ‘list’,
- with type constructor ‘Fields’
- and data constructor ‘BFields’.
- In the expression: emptyA {list = [a]}
- In a record update at field ‘sFields’,
- with type constructor ‘S’
- and data constructor ‘S’.
diff --git a/testsuite/tests/pmcheck/should_compile/T15450.hs b/testsuite/tests/pmcheck/should_compile/T15450.hs
index 100c8e8f7e60..e32a0c1483d3 100644
--- a/testsuite/tests/pmcheck/should_compile/T15450.hs
+++ b/testsuite/tests/pmcheck/should_compile/T15450.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
+
module T15450 where
f :: (Int ~ Bool) => Bool -> a
diff --git a/testsuite/tests/pmcheck/should_compile/T15450.stderr b/testsuite/tests/pmcheck/should_compile/T15450.stderr
index 18f4a931f899..4a49e9787104 100644
--- a/testsuite/tests/pmcheck/should_compile/T15450.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T15450.stderr
@@ -1,11 +1,11 @@
-T15450.hs:6:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+T15450.hs:7:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In a case alternative:
Patterns of type ‘Bool’ not matched:
False
True
-T15450.hs:9:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+T15450.hs:10:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In a case alternative: Patterns of type ‘Bool’ not matched: False
diff --git a/testsuite/tests/quantified-constraints/T17267b.hs b/testsuite/tests/quantified-constraints/T17267b.hs
index 82285d0265ca..5f0ffdf6e1c9 100644
--- a/testsuite/tests/quantified-constraints/T17267b.hs
+++ b/testsuite/tests/quantified-constraints/T17267b.hs
@@ -14,3 +14,22 @@ uc = oops where
oops :: (a ~ b => a ~ b) => a -> b
oops x = x
+{-
+Consider the ambiguity check for oops.
+
+[G] (a ~ b => a ~ b)
+[W] (a ~ b => a ~ b)
+==>
+
+[G] (a ~ b => a ~ b)
+[G] (a ~# b) was [G] (a ~ b) [G] a ~# b
+
+kick out the QC and (old) (a~b)
+[G] (b ~ b => b ~ b) Quantified constraint
+[G] (a ~# b) was [G] (b ~ b) [G] a ~# b
+
+[W] (a~b) DictCt
+
+Wanted is rewritten
+ (b~b) DictCt
+-}
diff --git a/testsuite/tests/tcplugins/ArgsPlugin.hs b/testsuite/tests/tcplugins/ArgsPlugin.hs
index 94f4dbe9d685..d5b98a2921c7 100644
--- a/testsuite/tests/tcplugins/ArgsPlugin.hs
+++ b/testsuite/tests/tcplugins/ArgsPlugin.hs
@@ -26,7 +26,7 @@ import GHC.Tc.Plugin
import GHC.Tc.Types
( TcPluginSolveResult(..) )
import GHC.Tc.Types.Constraint
- ( Ct(..) )
+ ( Ct(..), DictCt(..) )
import GHC.Tc.Types.Evidence
( EvBindsVar, EvTerm(EvExpr) )
import GHC.Platform
@@ -69,14 +69,14 @@ solver args defs _ev _gs ws = do
pure $ TcPluginOk solved []
solveCt :: Platform -> PluginDefs -> Integer -> Ct -> TcPluginM ( Maybe (EvTerm, Ct) )
-solveCt platform ( PluginDefs {..} ) i ct@( CDictCan { cc_class, cc_tyargs } )
- | className cc_class == className myClass
- , [tyArg] <- cc_tyargs
+solveCt platform ( PluginDefs {..} ) i ct@(CDictCan (DictCt { di_cls, di_tys } ))
+ | className di_cls == className myClass
+ , [tyArg] <- di_tys
, tyArg `eqType` integerTy
, let
evTerm :: EvTerm
evTerm = EvExpr $
- mkCoreConApps ( classDataCon cc_class )
+ mkCoreConApps ( classDataCon di_cls )
[ Type integerTy, mkIntegerExpr platform i ]
= pure $ Just ( evTerm, ct )
solveCt _ _ _ ct = pure Nothing
diff --git a/testsuite/tests/tcplugins/EmitWantedPlugin.hs b/testsuite/tests/tcplugins/EmitWantedPlugin.hs
index d43f4667adce..c83a0f37e6c8 100644
--- a/testsuite/tests/tcplugins/EmitWantedPlugin.hs
+++ b/testsuite/tests/tcplugins/EmitWantedPlugin.hs
@@ -30,7 +30,7 @@ import GHC.Tc.Plugin
import GHC.Tc.Types
( TcPluginSolveResult(..) )
import GHC.Tc.Types.Constraint
- ( Ct(..), ctLoc, ctEvCoercion, mkNonCanonical )
+ ( Ct(..), DictCt(..), ctLoc, ctEvCoercion, mkNonCanonical )
import GHC.Tc.Types.Evidence
( EvBindsVar, EvTerm(EvExpr) )
@@ -61,9 +61,9 @@ solver args defs _ev _gs ws = do
pure $ TcPluginOk solved new
solveCt :: PluginDefs -> Ct -> TcPluginM ( Maybe ( (EvTerm, Ct), Ct ) )
-solveCt ( PluginDefs {..} ) ct@( CDictCan { cc_class, cc_tyargs } )
- | className cc_class == className myClass
- , [tyArg] <- cc_tyargs
+solveCt ( PluginDefs {..} ) ct@( CDictCan (DictCt { di_cls, di_tys } ))
+ | className di_cls == className myClass
+ , [tyArg] <- di_tys
= do
new_wanted_ctev <- newWanted (ctLoc ct) (mkPrimEqPred tyArg unitTy)
let
diff --git a/testsuite/tests/tcplugins/NullaryPlugin.hs b/testsuite/tests/tcplugins/NullaryPlugin.hs
index 742054fcda3d..64b1a83a11aa 100644
--- a/testsuite/tests/tcplugins/NullaryPlugin.hs
+++ b/testsuite/tests/tcplugins/NullaryPlugin.hs
@@ -20,7 +20,7 @@ import GHC.Tc.Plugin
import GHC.Tc.Types
( TcPluginSolveResult(..) )
import GHC.Tc.Types.Constraint
- ( Ct(..) )
+ ( Ct(..), DictCt(..) )
import GHC.Tc.Types.Evidence
( EvBindsVar, EvTerm(EvExpr) )
@@ -49,10 +49,10 @@ solver _args defs _ev _gs ws = do
pure $ TcPluginOk solved []
solveCt :: PluginDefs -> Ct -> TcPluginM ( Maybe (EvTerm, Ct) )
-solveCt ( PluginDefs {..} ) ct@( CDictCan { cc_class } )
- | className cc_class == className nullary
+solveCt ( PluginDefs {..} ) ct@( CDictCan (DictCt { di_cls } ))
+ | className di_cls == className nullary
, let
evTerm :: EvTerm
- evTerm = EvExpr $ mkCoreConApps ( classDataCon cc_class ) []
+ evTerm = EvExpr $ mkCoreConApps ( classDataCon di_cls ) []
= pure $ Just ( evTerm, ct )
solveCt _ ct = pure Nothing
diff --git a/testsuite/tests/typecheck/should_compile/CbvOverlap.hs b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs
index 4e3b40f16138..7c881898b460 100644
--- a/testsuite/tests/typecheck/should_compile/CbvOverlap.hs
+++ b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs
@@ -2,7 +2,7 @@
module CbvOverlap where
--- This is concerned with Note [Type variable cycles in Givens] and class lookup
+-- This is concerned with Note [Type equality cycles] and class lookup
class C a where
meth :: a -> ()
diff --git a/testsuite/tests/typecheck/should_compile/Improvement.hs b/testsuite/tests/typecheck/should_compile/Improvement.hs
index 3e15139853b5..0cf7c81cd965 100644
--- a/testsuite/tests/typecheck/should_compile/Improvement.hs
+++ b/testsuite/tests/typecheck/should_compile/Improvement.hs
@@ -6,9 +6,6 @@
-- [W] C (F a0) a0, F a0 ~ Bool
-- Currently (Oct 16) I've disabled this because it seems like
-- overkill.
---
--- See Note Note [No reduction for Derived class constraints]
--- in GHC.Tc.Solver.Interact
module Foo where
diff --git a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs
index 765379a2032a..14d871735161 100644
--- a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs
+++ b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs
@@ -3,7 +3,7 @@
module InstanceGivenOverlap where
--- See Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
+-- See Note [Instance and Given overlap] in GHC.Tc.Solver.Dict.
-- This tests the Note when the Wanted contains a type family.
class P a
diff --git a/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
index 43063d20aa7b..a84a1d2dd49b 100644
--- a/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
+++ b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
@@ -18,8 +18,8 @@ us [G] b ~ (Body b) GhcPs. In order to infer the type of happy_var_2, we need to
float some wanted out past this equality. We have Note [Let-bound skolems]
in GHC.Tc.Solver.Monad to consider this Given equality to be let-like, and thus
not prevent floating. But, note that the equality isn't quite let-like, because
-it mentions b in its RHS. It thus triggers Note [Type variable cycles in Givens]
-in GHC.Tc.Solver.Canonical. That Note says we change the situation to
+it mentions b in its RHS. It thus triggers Note [Type equality cycles]
+in GHC.Tc.Solver.Equality. That Note says we change the situation to
[G] b ~ cbv GhcPs
[G] Body b ~ cbv
for some fresh CycleBreakerTv cbv. Now, our original equality looks to be let-like,
diff --git a/testsuite/tests/typecheck/should_fail/T14325.hs b/testsuite/tests/typecheck/should_fail/T14325.hs
index edb603816574..f549a91236fb 100644
--- a/testsuite/tests/typecheck/should_fail/T14325.hs
+++ b/testsuite/tests/typecheck/should_fail/T14325.hs
@@ -9,3 +9,12 @@ foo x = x
hm3 :: C (f b) b => b -> f b
hm3 x = foo x
+
+{- Typechecking hm3
+~~~~~~~~~~~~~~~~~~~
+[G] C (f b) b
+[G] f b ~# b -- Superclass; but Irred because occurs check
+[W] C b (f b)
+
+So the wanted can't be solved and is reported
+-}
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/T14325.stderr b/testsuite/tests/typecheck/should_fail/T14325.stderr
index 787a60220947..18abad2f5be2 100644
--- a/testsuite/tests/typecheck/should_fail/T14325.stderr
+++ b/testsuite/tests/typecheck/should_fail/T14325.stderr
@@ -1,14 +1,9 @@
-T14325.hs:11:9: error: [GHC-25897]
- • Couldn't match type ‘b’ with ‘f b’
- arising from a superclass required to satisfy ‘C b (f b)’,
- arising from a use of ‘foo’
- ‘b’ is a rigid type variable bound by
- the type signature for:
- hm3 :: forall (f :: * -> *) b. C (f b) b => b -> f b
+T14325.hs:11:9: error: [GHC-39999]
+ • Could not deduce ‘C b (f b)’ arising from a use of ‘foo’
+ from the context: C (f b) b
+ bound by the type signature for:
+ hm3 :: forall (f :: * -> *) b. C (f b) b => b -> f b
at T14325.hs:10:1-28
• In the expression: foo x
In an equation for ‘hm3’: hm3 x = foo x
- • Relevant bindings include
- x :: b (bound at T14325.hs:11:5)
- hm3 :: b -> f b (bound at T14325.hs:11:1)
diff --git a/testsuite/tests/typecheck/should_fail/T22924b.stderr b/testsuite/tests/typecheck/should_fail/T22924b.stderr
index ba4bd79198c4..46f456fc1f2d 100644
--- a/testsuite/tests/typecheck/should_fail/T22924b.stderr
+++ b/testsuite/tests/typecheck/should_fail/T22924b.stderr
@@ -1,7 +1,7 @@
T22924b.hs:10:5: error:
• Reduction stack overflow; size = 201
- When simplifying the following type: R
+ When simplifying the following type: S
Use -freduction-depth=0 to disable this check
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
index bbb18280c729..be1b5928b355 100644
--- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
+++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
@@ -50,7 +50,7 @@ TcCoercibleFail.hs:30:9: error: [GHC-18872]
TcCoercibleFail.hs:35:8: error:
• Reduction stack overflow; size = 201
- When simplifying the following type: Age
+ When simplifying the following type: Fix (Either Age)
Use -freduction-depth=0 to disable this check
(any upper bound you could choose might fail unpredictably with
minor updates to GHC, so disabling the check is recommended if
diff --git a/testsuite/tests/typecheck/should_run/Defer01.hs b/testsuite/tests/typecheck/should_run/Defer01.hs
index 551c626f7c4c..a844073d0a0f 100644
--- a/testsuite/tests/typecheck/should_run/Defer01.hs
+++ b/testsuite/tests/typecheck/should_run/Defer01.hs
@@ -1,6 +1,5 @@
-- Test -fdefer-type-errors
-- Should compile and run
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
diff --git a/testsuite/tests/typecheck/should_run/Typeable1.stderr b/testsuite/tests/typecheck/should_run/Typeable1.stderr
index d9ee7781d581..17817ade2617 100644
--- a/testsuite/tests/typecheck/should_run/Typeable1.stderr
+++ b/testsuite/tests/typecheck/should_run/Typeable1.stderr
@@ -9,8 +9,8 @@ Typeable1.hs:22:5: error: [GHC-40564] [-Winaccessible-code (in -Wdefault), Werro
TypeRep a -> TypeRep b -> TypeRep t,
in a pattern binding in
a 'do' block
- Couldn't match type: ComposeK
- with: a3 b3
+ Couldn't match type: a3 b3
+ with: ComposeK
• In the pattern: App x y
In a stmt of a 'do' block: App x y <- pure x
In the expression:
--
GitLab