summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs7
-rw-r--r--compiler/GHC/Tc/Module.hs13
-rw-r--r--compiler/GHC/Tc/Solver.hs2
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs4
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs9
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs3
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs6
8 files changed, 24 insertions, 23 deletions
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 278b63f03c..b66ad2d447 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -388,10 +388,9 @@ makeLitDict clas ty et
| Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
-- co_dict :: KnownNat n ~ SNat n
, [ meth ] <- classMethods clas
- , Just tcRep <- tyConAppTyCon_maybe -- SNat
- $ funResultTy -- SNat n
- $ dropForAlls -- KnownNat n => SNat n
- $ idType meth -- forall n. KnownNat n => SNat n
+ , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)
+ -- If the method type is forall n. KnownNat n => SNat n
+ -- then tcRep is SNat
, Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-- SNat n ~ Integer
, let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 311f87458f..20538dd230 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -65,9 +65,10 @@ import GHC.Builtin.Types ( unitTy, mkListTy )
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Hs
-import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
-import GHC.Iface.Type ( ShowForAllFlag(..) )
-import GHC.Core.PatSyn( pprPatSynType )
+import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
+import GHC.Iface.Type ( ShowForAllFlag(..) )
+import GHC.Core.PatSyn ( pprPatSynType )
+import GHC.Core.Predicate ( classMethodTy )
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Types.Name.Reader
@@ -1014,10 +1015,8 @@ checkBootTyCon is_boot tc1 tc2
name2 = idName id2
pname1 = quotes (ppr name1)
pname2 = quotes (ppr name2)
- (_, rho_ty1) = splitForAllTys (idType id1)
- op_ty1 = funResultTy rho_ty1
- (_, rho_ty2) = splitForAllTys (idType id2)
- op_ty2 = funResultTy rho_ty2
+ op_ty1 = classMethodTy id1
+ op_ty2 = classMethodTy id2
eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
= checkBootTyCon is_boot tc1 tc2 `andThenCheck`
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 96fe5cbca2..1ea65b2aa4 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -1377,7 +1377,7 @@ growThetaTyVars theta tcvs
| otherwise = transCloVarSet mk_next seed_tcvs
where
seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
- (ips, non_ips) = partition isIPPred theta
+ (ips, non_ips) = partition isIPLikePred theta
-- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType
mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index ce663d9764..557e56f48f 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -29,7 +29,7 @@ import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking
import GHC.Core.Coercion
import GHC.Core
-import GHC.Types.Id( idType, mkTemplateLocals )
+import GHC.Types.Id( mkTemplateLocals )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
import GHC.Types.Var
@@ -542,7 +542,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
mk_given_desc sel_id sc_pred
; mk_superclasses rec_clss given_ev tvs theta sc_pred }
where
- sc_pred = funResultTy (piResultTys (idType sel_id) tys)
+ sc_pred = classMethodInstTy sel_id tys
-- See Note [Nested quantified constraint superclasses]
mk_given_desc :: Id -> PredType -> (PredType, EvTerm)
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index adc28d994a..bbdfb56b71 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -566,10 +566,10 @@ solveOneFromTheOther ev_i ev_w
ev_id_w = ctEvEvId ev_w
different_level_strategy -- Both Given
- | isIPPred pred = if lvl_w > lvl_i then KeepWork else KeepInert
- | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork
+ | 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] (the different-level bullet)
- -- For the isIPPred case see Note [Shadowing of Implicit Parameters]
+ -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters]
same_level_strategy binds -- Both Given
| GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
@@ -1071,6 +1071,8 @@ shortCutSolver dflags ev_w ev_i
-- 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
@@ -1079,6 +1081,7 @@ shortCutSolver dflags ev_w ev_i
&& gopt Opt_SolveConstantDicts dflags
-- Enabled by the -fsolve-constant-dicts flag
+
= do { ev_binds_var <- getTcEvBindsVar
; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
getTcEvBindsMap ev_binds_var
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 49a3fb5c46..67340ffc47 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -2527,8 +2527,7 @@ emptyDictMap = emptyTcAppMap
findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
findDict m loc cls tys
- | isCTupleClass cls
- , any hasIPPred tys -- See Note [Tuples hiding implicit parameters]
+ | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]
= Nothing
| Just {} <- isCallStackPred cls tys
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 42ec78276e..36d25d0eaf 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -54,6 +54,7 @@ import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID )
import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
import GHC.Core.Type
import GHC.Core.SimpleOpt
+import GHC.Core.Predicate( classMethodInstTy )
import GHC.Tc.Types.Evidence
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
@@ -1634,7 +1635,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
nO_METHOD_BINDING_ERROR_ID
error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText
(unsafeMkByteString (error_string dflags))))
- meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
+ meth_tau = classMethodInstTy sel_id inst_tys
error_string dflags = showSDoc dflags
(hcat [ppr inst_loc, vbar, ppr sel_id ])
lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 357858cf9a..21b6b962d9 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -79,7 +79,7 @@ module GHC.Tc.Utils.TcType (
isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isNaturalTy,
isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
- hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+ isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
checkValidClsArgs, hasTyVarHead,
isRigidTy, isAlmostFunctionFree,
@@ -141,7 +141,7 @@ module GHC.Tc.Utils.TcType (
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
- isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass,
+ isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,
mkClassPred,
tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isKindLevPoly,
@@ -1747,7 +1747,7 @@ pickCapturedPreds
pickCapturedPreds qtvs theta
= filter captured theta
where
- captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
+ captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
-- Superclasses
View Lorry Controller Status