Commit 9f978b67 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #10642.

Representational equalities cannot discharge nominal ones.
Even if, somehow, this didn't cause a type error (as reported
in the ticket), it would surely cause a core lint error.
parent 75fd5dc2
......@@ -1086,10 +1086,10 @@ flatten_exact_fam_app_fully tc tys
-- Now, look in the cache
; mb_ct <- liftTcS $ lookupFlatCache tc xis
; flavour <- getFlavour
; flavour_role <- getFlavourRole
; case mb_ct of
Just (co, rhs_ty, flav) -- co :: F xis ~ fsk
| flav `canDischargeF` flavour
| (flav, NomEq) `canDischargeFR` flavour_role
-> -- Usable hit in the flat-cache
-- We certainly *can* use a Wanted for a Wanted
do { traceFlat "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty)
......@@ -1500,4 +1500,3 @@ unsolved constraints. The flat form will be
Flatten using the fun-eqs first.
-}
......@@ -89,7 +89,7 @@ module TcRnTypes(
CtFlavour(..), ctEvFlavour,
CtFlavourRole, ctEvFlavourRole, ctFlavourRole,
eqCanRewrite, eqCanRewriteFR, canDischarge, canDischargeF,
eqCanRewrite, eqCanRewriteFR, canDischarge, canDischargeFR,
-- Pretty printing
pprEvVarTheta,
......@@ -1903,14 +1903,15 @@ eqCanRewriteFR _ _ = False
canDischarge :: CtEvidence -> CtEvidence -> Bool
-- See Note [canRewriteOrSame]
canDischarge ev1 ev2 = ctEvFlavour ev1 `canDischargeF` ctEvFlavour ev2
canDischarge ev1 ev2 = ctEvFlavourRole ev1 `canDischargeFR` ctEvFlavourRole ev2
canDischargeF :: CtFlavour -> CtFlavour -> Bool
canDischargeF Given _ = True
canDischargeF Wanted Wanted = True
canDischargeF Wanted Derived = True
canDischargeF Derived Derived = True
canDischargeF _ _ = False
canDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool
canDischargeFR (_, ReprEq) (_, NomEq) = False
canDischargeFR (Given, _) _ = True
canDischargeFR (Wanted, _) (Wanted, _) = True
canDischargeFR (Wanted, _) (Derived, _) = True
canDischargeFR (Derived, _) (Derived, _) = True
canDischargeFR _ _ = False
{-
......@@ -2299,7 +2300,7 @@ pprCtO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"),
pprCtO SectionOrigin = ptext (sLit "an operator section")
pprCtO TupleOrigin = ptext (sLit "a tuple")
pprCtO NegateOrigin = ptext (sLit "a use of syntactic negation")
pprCtO (ScOrigin n) = ptext (sLit "the superclasses of an instance declaration")
pprCtO (ScOrigin n) = ptext (sLit "the superclasses of an instance declaration")
<> ifPprDebug (parens (ppr n))
pprCtO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration")
pprCtO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
......
......@@ -2755,7 +2755,8 @@ newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
newWantedEvVarNC loc pty
= do { -- checkReductionDepth loc pty
; new_ev <- newEvVar pty
; traceTcS "Emitting new wanted" (ppr new_ev $$ pprCtLoc loc)
; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
pprCtLoc loc)
; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })}
newWantedEvVar :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness)
......
{-# LANGUAGE TypeFamilies #-}
module T10642 where
import Data.Coerce
type family F a
newtype D a = D (F a)
-- | This works on 7.10.1, but fails on HEAD (20150711)
coerceD :: F a -> D a
coerceD = coerce
......@@ -466,3 +466,4 @@ test('T10428', normal, compile, [''])
test('RepArrow', normal, compile, [''])
test('T10562', normal, compile, [''])
test('T10564', normal, compile, [''])
test('T10642', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment