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.

compiler/typecheck/TcFlatten.hs

@@ -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.
 -}
-

compiler/typecheck/TcRnTypes.hs

@@ -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")

compiler/typecheck/TcSMonad.hs

@@ -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)

testsuite/tests/typecheck/should_compile/T10642.hs

+{-# 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

testsuite/tests/typecheck/should_compile/all.T

@@ -466,3 +466,4 @@ test('T10428', normal, compile, [''])
 test('RepArrow', normal, compile, [''])
 test('T10562', normal, compile, [''])
 test('T10564', normal, compile, [''])
+test('T10642', normal, compile, [''])