Commit 73a7383e authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Marge Bot
Browse files

Simplify treatment of heterogeneous equality

Previously, if we had a [W] (a :: k1) ~ (rhs :: k2), we would
spit out a [D] k1 ~ k2 and part the W as irreducible, hoping for
a unification. But we needn't do this. Instead, we now spit out
a [W] co :: k2 ~ k1 and then use co to cast the rhs of the original
Wanted. This means that we retain the connection between the
spat-out constraint and the original.

The problem with this new approach is that we cannot use the
casted equality for substitution; it's too like wanteds-rewriting-
wanteds. So, we forbid CTyEqCans that mention coercion holes.

All the details are in Note [Equalities with incompatible kinds]
in TcCanonical.

There are a few knock-on effects, documented where they occur.

While debugging an error in this patch, Simon and I ran into
infelicities in how patterns and matches are printed; we made
small improvements.

This patch includes mitigations for #17828, which causes spurious
pattern-match warnings. When #17828 is fixed, these lines should
be removed.
parent cb1785d9
Pipeline #16959 passed with stages
in 559 minutes and 52 seconds
......@@ -12,7 +12,8 @@
module GHC.Core.Coercion (
-- * Main data type
Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),
coHoleCoVar, setCoHoleCoVar,
LeftOrRight(..),
Var, CoVar, TyCoVar,
Role(..), ltRole,
......@@ -111,7 +112,9 @@ module GHC.Core.Coercion (
-- * Other
promoteCoercion, buildCoercion,
simplifyArgsWorker
simplifyArgsWorker,
badCoercionHole, badCoercionHoleCo
) where
#include "HsVersions.h"
......@@ -148,6 +151,7 @@ import UniqFM
import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
import Data.Char( isDigit )
import qualified Data.Monoid as Monoid
{-
%************************************************************************
......@@ -2904,3 +2908,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
ppr (take 10 orig_roles), -- often infinite!
ppr orig_tys])
-}
{-
%************************************************************************
%* *
Coercion holes
%* *
%************************************************************************
-}
bad_co_hole_ty :: Type -> Monoid.Any
bad_co_hole_co :: Coercion -> Monoid.Any
(bad_co_hole_ty, _, bad_co_hole_co, _)
= foldTyCo folder ()
where
folder = TyCoFolder { tcf_view = const Nothing
, tcf_tyvar = const2 (Monoid.Any False)
, tcf_covar = const2 (Monoid.Any False)
, tcf_hole = const hole
, tcf_tycobinder = const2
}
const2 :: a -> b -> c -> a
const2 x _ _ = x
hole :: CoercionHole -> Monoid.Any
hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True
hole _ = Monoid.Any False
-- | Is there a blocking coercion hole in this type? See
-- TcCanonical Note [Equalities with incompatible kinds]
badCoercionHole :: Type -> Bool
badCoercionHole = Monoid.getAny . bad_co_hole_ty
-- | Is there a blocking coercion hole in this coercion? See
-- TcCanonical Note [Equalities with incompatible kinds]
badCoercionHoleCo :: Coercion -> Bool
badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
......@@ -39,7 +39,7 @@ module GHC.Core.TyCo.Rep (
-- * Coercions
Coercion(..),
UnivCoProvenance(..),
CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,
CoercionN, CoercionR, CoercionP, KindCoercion,
MCoercion(..), MCoercionR, MCoercionN,
......@@ -1487,12 +1487,18 @@ instance Outputable UnivCoProvenance where
-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]
data CoercionHole
= CoercionHole { ch_co_var :: CoVar
= CoercionHole { ch_co_var :: CoVar
-- See Note [CoercionHoles and coercion free variables]
, ch_ref :: IORef (Maybe Coercion)
, ch_blocker :: BlockSubstFlag -- should this hole block substitution?
-- See (2a) in TcCanonical
-- Note [Equalities with incompatible kinds]
, ch_ref :: IORef (Maybe Coercion)
}
data BlockSubstFlag = YesBlockSubst
| NoBlockSubst
coHoleCoVar :: CoercionHole -> CoVar
coHoleCoVar = ch_co_var
......@@ -1508,6 +1514,9 @@ instance Data.Data CoercionHole where
instance Outputable CoercionHole where
ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)
instance Outputable BlockSubstFlag where
ppr YesBlockSubst = text "YesBlockSubst"
ppr NoBlockSubst = text "NoBlockSubst"
{- Note [Phantom coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -1089,10 +1089,9 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcPs -> ppr x
GhcRn -> ppr x
GhcTc -> case x of
HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c))
......@@ -1118,7 +1117,7 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
-- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
-- = char '@' <> pprHsType arg
pp (Right arg)
= char '@' <> ppr arg
= text "@" <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
......@@ -1712,41 +1711,39 @@ pprPatBind pat (grhss)
pprMatch :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatch match
pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
= sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
, nest 2 (pprGRHSs ctxt grhss) ]
where
ctxt = m_ctxt match
(herald, other_pats)
= case ctxt of
FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
| strictness == SrcStrict -> ASSERT(null $ m_pats match)
(char '!'<>pprPrefixOcc fun, m_pats match)
-- a strict variable binding
| fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
-- f x y z = e
-- Not pprBndr; the AbsBinds will
-- have printed the signature
| null pats2 -> (pp_infix, [])
-- x &&& y = e
| otherwise -> (parens pp_infix, pats2)
-- (x &&& y) z = e
where
pp_infix = pprParendLPat opPrec pat1
<+> pprInfixOcc fun
<+> pprParendLPat opPrec pat2
LambdaExpr -> (char '\\', m_pats match)
_ -> if null (m_pats match)
then (empty, [])
else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
(ppr pat1, []) -- No parens around the single pat
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
| SrcStrict <- strictness
-> ASSERT(null pats) -- A strict variable binding
(char '!'<>pprPrefixOcc fun, pats)
| Prefix <- fixity
-> (pprPrefixOcc fun, pats) -- f x y z = e
-- Not pprBndr; the AbsBinds will
-- have printed the signature
| otherwise
-> case pats of
(p1:p2:rest)
| null rest -> (pp_infix, []) -- x &&& y = e
| otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e
where
pp_infix = pprParendLPat opPrec p1
<+> pprInfixOcc fun
<+> pprParendLPat opPrec p2
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
LambdaExpr -> (char '\\', pats)
_ -> case pats of
[] -> (empty, [])
[pat] -> (ppr pat, []) -- No parens around the single pat in a case
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
pprMatch (XMatch nec) = noExtCon nec
pprGRHSs :: (OutputableBndrId idR, Outputable body)
=> HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
......
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
......@@ -58,6 +59,7 @@ import TcEvidence
import BasicTypes
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )
import TysWiredIn
import Var
import RdrName ( RdrName )
......@@ -526,10 +528,11 @@ pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice) = pprSplice splice
pprPat (CoPat _ co pat _) = pprIfTc @p $
pprHsWrapper co $ \parens
-> if parens
then pprParendPat appPrec pat
else pprPat pat
sdocWithDynFlags $ \ dflags ->
if gopt Opt_PrintTypecheckerElaboration dflags
then hang (text "CoPat" <+> parens (ppr co))
2 (pprParendPat appPrec pat)
else pprPat pat
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
where ppr_ty = case ghcPass @p of
GhcPs -> ppr ty
......
......@@ -32,7 +32,7 @@ import GHC.Core (CoreExpr, Expr(Var,App))
import FastString (unpackFS, lengthFS)
import GHC.Driver.Session
import GHC.Hs
import TcHsSyn
import TcHsSyn ( shortCutLit )
import Id
import GHC.Core.ConLike
import Name
......@@ -45,7 +45,7 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import Var (EvVar)
import GHC.Core.Coercion
import TcEvidence
import TcEvidence ( HsWrapper(..), isIdHsWrapper )
import TcType (evVarPred)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
......@@ -999,7 +999,7 @@ checkGrdTree guards deltas = do
tracePm "checkGrdTree {" $ vcat [ ppr guards
, ppr deltas ]
res <- checkGrdTree' guards deltas
tracePm "}:" (ppr res) -- braces are easier to match by tooling
tracePm "checkGrdTree }:" (ppr res) -- braces are easier to match by tooling
return res
-- ----------------------------------------------------------------------------
......
......@@ -14,7 +14,7 @@ module Constraint (
QCInst(..), isPendingScInst,
-- Canonical constraints
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts, isCTyEqCan, isCFunEqCan,
isPendingScDict, superClassesMightHelp, getPendingWantedScs,
......@@ -25,7 +25,7 @@ module Constraint (
ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
ctEvId, mkTcEqPredLikeEv,
mkNonCanonical, mkNonCanonicalCt, mkGivens,
mkIrredCt, mkInsolubleCt,
mkIrredCt,
ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
tyCoVarsOfCt, tyCoVarsOfCts,
......@@ -145,13 +145,12 @@ data Ct
}
| CIrredCan { -- These stand for yet-unusable predicates
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_insol :: Bool -- True <=> definitely an error, can never be solved
-- False <=> might be soluble
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_status :: CtIrredStatus
-- 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 (tv1 ~ ty2) where the CTyEqCan kind invariant fails
-- or (tv1 ~ ty2) where the CTyEqCan kind invariant (TyEq:K) fails
-- or (F tys ~ ty) where the CFunEqCan kind invariant fails
-- See Note [CIrredCan constraints]
......@@ -163,19 +162,21 @@ data Ct
| CTyEqCan { -- tv ~ rhs
-- Invariants:
-- * See Note [inert_eqs: the inert equalities] in TcSMonad
-- * tv not in tvs(rhs) (occurs check)
-- * If tv is a TauTv, then rhs has no foralls
-- * (TyEq:OC) tv not in deep tvs(rhs) (occurs check)
-- * (TyEq:F) If tv is a TauTv, then rhs has no foralls
-- (this avoids substituting a forall for the tyvar in other types)
-- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]
-- * rhs may have at most one top-level cast
-- * rhs (perhaps under the one cast) is *almost function-free*,
-- * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]
-- * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*,
-- See Note [Almost function-free]
-- * If the equality is representational, rhs has no top-level newtype
-- * (TyEq:N) If the equality is representational, rhs has no top-level newtype
-- See Note [No top-level newtypes on RHS of representational
-- equalities] in TcCanonical
-- * If rhs (perhaps under the cast) is also a tv, then it is oriented
-- * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented
-- to give best chance of
-- unification happening; eg if rhs is touchable then lhs is too
-- See TcCanonical Note [Canonical orientation for tyvar/tyvar equality constraints]
-- * (TyEq:H) The RHS has no blocking coercion holes. See TcCanonical
-- Note [Equalities with incompatible kinds], wrinkle (2)
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_tyvar :: TcTyVar,
cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi)
......@@ -241,6 +242,21 @@ data HoleSort = ExprHole
| TypeHole
-- ^ A hole in a type (PartialTypeSignatures)
------------
-- | Used to indicate extra information about why a CIrredCan is irreducible
data CtIrredStatus
= InsolubleCIS -- this constraint will never be solved
| BlockedCIS -- this constraint is blocked on a coercion hole
-- The hole will appear in the ctEvPred of the constraint with this status
-- See Note [Equalities with incompatible kinds] in TcCanonical
-- Wrinkle (4a)
| OtherCIS
instance Outputable CtIrredStatus where
ppr InsolubleCIS = text "(insoluble)"
ppr BlockedCIS = text "(blocked)"
ppr OtherCIS = text "(soluble)"
{- Note [Hole constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~
CHoleCan constraints are used for two kinds of holes,
......@@ -296,7 +312,8 @@ responds True to isTypeFamilyTyCon), except (possibly)
* under a forall, or
* in a coercion (either in a CastTy or a CercionTy)
The RHS of a CTyEqCan must be almost function-free. This is for two reasons:
The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF).
This is for two reasons:
1. There cannot be a top-level function. If there were, the equality should
really be a CFunEqCan, not a CTyEqCan.
......@@ -346,11 +363,8 @@ mkNonCanonical ev = CNonCanonical { cc_ev = ev }
mkNonCanonicalCt :: Ct -> Ct
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
mkIrredCt :: CtEvidence -> Ct
mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False }
mkInsolubleCt :: CtEvidence -> Ct
mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True }
mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct
mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status }
mkGivens :: CtLoc -> [EvId] -> [Ct]
mkGivens loc ev_ids
......@@ -409,9 +423,7 @@ instance Outputable Ct where
CDictCan { cc_pend_sc = pend_sc }
| pend_sc -> text "CDictCan(psc)"
| otherwise -> text "CDictCan"
CIrredCan { cc_insol = insol }
| insol -> text "CIrredCan(insol)"
| otherwise -> text "CIrredCan(sol)"
CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status
CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ
CQuantCan (QCI { qci_pend_sc = pend_sc })
| pend_sc -> text "CQuantCan(psc)"
......@@ -439,14 +451,10 @@ tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt
-- | Returns free variables of constraints as a composable FV computation.
-- See Note [Deterministic FV] in FV.
tyCoFVsOfCt :: Ct -> FV
tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })
= tyCoFVsOfType xi `unionFV` FV.unitFV tv
`unionFV` tyCoFVsOfType (tyVarKind tv)
tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk })
= tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk
`unionFV` tyCoFVsOfType (tyVarKind fsk)
tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys
tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)
-- This must consult only the ctPred, so that it gets *tidied* fvs if the
-- constraint has been tidied. Tidying a constraint does not tidy the
-- fields of the Ct, only the predicate in the CtEvidence.
-- | Returns free variables of a bag of constraints as a non-deterministic
-- set. See Note [Deterministic FV] in FV.
......@@ -549,18 +557,15 @@ isDroppableCt ct
keep_deriv
= case ct of
CHoleCan {} -> True
CIrredCan { cc_insol = insoluble }
-> keep_eq insoluble
_ -> keep_eq False
CHoleCan {} -> True
CIrredCan { cc_status = InsolubleCIS } -> keep_eq True
_ -> keep_eq False
keep_eq definitely_insoluble
| isGivenOrigin orig -- Arising only from givens
= definitely_insoluble -- Keep only definitely insoluble
| otherwise
= case orig of
KindEqOrigin {} -> True -- See Note [Dropping derived constraints]
-- See Note [Dropping derived constraints]
-- For fundeps, drop wanted/wanted interactions
FunDepOrigin2 {} -> True -- Top-level/Wanted
......@@ -610,12 +615,6 @@ But (tiresomely) we do keep *some* Derived constraints:
* Type holes are derived constraints, because they have no evidence
and we want to keep them, so we get the error report
* Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with
KindEqOrigin, may arise from a type equality a ~ Int#, say. See
Note [Equalities with incompatible kinds] in TcCanonical.
Keeping these around produces better error messages, in practice.
E.g., test case dependent/should_fail/T11471
* We keep most derived equalities arising from functional dependencies
- Given/Given interactions (subset of FunDepOrigin1):
The definitely-insoluble ones reflect unreachable code.
......@@ -664,7 +663,6 @@ isDerivedCt = isDerived . ctEvidence
isCTyEqCan :: Ct -> Bool
isCTyEqCan (CTyEqCan {}) = True
isCTyEqCan (CFunEqCan {}) = False
isCTyEqCan _ = False
isCDictCan_Maybe :: Ct -> Maybe Class
......@@ -990,8 +988,8 @@ insolubleEqCt :: Ct -> Bool
-- 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_insol = insol }) = insol
insolubleEqCt _ = False
insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True
insolubleEqCt _ = False
instance Outputable WantedConstraints where
ppr (WC {wc_simple = s, wc_impl = i})
......
This diff is collapsed.
......@@ -28,6 +28,7 @@ import TcType
import TcOrigin
import GHC.Rename.Unbound ( unknownNameSuggestions )
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )
import GHC.Core.Unify ( tcMatchTys )
......@@ -61,7 +62,6 @@ import SrcLoc
import GHC.Driver.Session
import ListSetOps ( equivClasses )
import Maybes
import Pair
import qualified GHC.LanguageExtensions as LangExt
import FV ( fvVarList, unionFV )
......@@ -549,7 +549,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
-- See Note [Do not report derived but soluble errors]
; mapBagM_ (reportImplic ctxt2) implics }
-- NB ctxt1: don't suppress inner insolubles if there's only a
-- NB ctxt2: don't suppress inner insolubles if there's only a
-- wanted insoluble here; but do suppress inner insolubles
-- if there's a *given* insoluble here (= inaccessible code)
where
......@@ -562,29 +562,36 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
-- (see TcRnTypes.insolubleCt) is caught here, otherwise
-- we might suppress its error message, and proceed on past
-- type checking to get a Lint error later
report1 = [ ("Out of scope", is_out_of_scope, True, mkHoleReporter tidy_cts)
, ("Holes", is_hole, False, mkHoleReporter tidy_cts)
, ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
report1 = [ ("Out of scope", unblocked is_out_of_scope, True, mkHoleReporter tidy_cts)
, ("Holes", unblocked is_hole, False, mkHoleReporter tidy_cts)
, ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter)
, given_eq_spec
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("skolem eq2", skolem_eq, True, mkSkolReporter)
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
, ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", unblocked very_wrong, True, mkSkolReporter)
, ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter)
, ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter)
-- The only remaining equalities are alpha ~ ty,
-- 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 TcCanonical
, ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ]
, ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr)
, ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)]
-- report2: we suppress these if there are insolubles elsewhere in the tree
report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
, ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
-- also checks to make sure the constraint isn't BlockedCIS
-- See TcCanonical Note [Equalities with incompatible kinds], (4)
unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool
unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False
unblocked checker ct pred = checker ct pred
-- rigid_nom_eq, rigid_nom_tv_eq,
is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> Pred -> Bool
......@@ -796,6 +803,11 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
-- Like mkGroupReporter, but doesn't actually print error messages
mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkSuppressReporter mk_err ctxt cts
= mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
......@@ -806,8 +818,7 @@ eq_lhs_type ct1 ct2
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup mk_err ctxt cts =
ASSERT( not (null cts))
do { err <- mk_err ctxt cts
......@@ -824,6 +835,14 @@ reportGroup mk_err ctxt cts =
-- but that's hard to know for sure, and if we don't
-- abort, we need bindings for all (e.g. #12156)
-- like reportGroup, but does not actually report messages. It still adds
-- -fdefer-type-errors bindings, though.
suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
suppressGroup mk_err ctxt cts
= do { err <- mk_err ctxt cts
; traceTc "Suppressing errors for" (ppr cts)
; mapM_ (addDeferredBinding ctxt err) cts }
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
-- Unlike maybeReportError, these "hole" errors are
-- /not/ suppressed by cec_suppress. We want to see them!
......@@ -1439,10 +1458,10 @@ mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
-> Maybe SwapFlag -- Nothing <=> not sure
-> TcType -> TcType -> TcM ErrMsg
mkEqErr_help dflags ctxt report ct oriented ty1 ty2
| Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1
= mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
| Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
= mkTyVarEqErr dflags ctxt report ct swapped tv2 co2 ty1
| Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
= mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
| Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
= mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1
| otherwise
= reportEqErr ctxt report ct oriented ty1 ty2
where
......@@ -1459,13 +1478,13 @@ reportEqErr ctxt report ct oriented ty1 ty2
mkTyVarEqErr, mkTyVarEqErr'
:: DynFlags -> ReportErrCtxt -> Report -> Ct
-> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
-> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied
mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)
; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }
mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 }
mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
| not insoluble_occurs_check -- See Note [Occurs check wins]
, isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
-- be oriented the other way round;
......@@ -1514,23 +1533,6 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
-- to be helpful since this is just an unimplemented feature.
; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
-- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]
-- in TcCanonical
| not (k1 `tcEqType` k2)
= do { let main_msg = addArising (ctOrigin ct) $
vcat [ hang (text "Kind mismatch: cannot unify" <+>
parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
text "with:")
2 (sep [ppr ty2, dcolon, ppr k2])
, text "Their kinds differ." ]
cast_msg
| isTcReflexiveCo co1 = empty
| otherwise = text "NB:" <+> ppr tv1 <+>
text "was casted to have kind" <+>
quotes (ppr k1)