[commit: ghc] master: Fix #10642. (9f978b6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/9f978b67212a51fa34ef44db463351b959ff15e4/ghc

>---------------------------------------------------------------

commit 9f978b67212a51fa34ef44db463351b959ff15e4
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Jul 15 09:50:57 2015 -0400

    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.


>---------------------------------------------------------------

9f978b67212a51fa34ef44db463351b959ff15e4
 compiler/typecheck/TcFlatten.hs                    |  5 ++---
 compiler/typecheck/TcRnTypes.hs                    | 19 ++++++++++---------
 compiler/typecheck/TcSMonad.hs                     |  3 ++-
 testsuite/tests/typecheck/should_compile/T10642.hs | 12 ++++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 5 files changed, 27 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
index 5ecec90..9df0690 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/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.
 -}
-
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index c2d5da0..4d36243 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/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
-
-canDischargeF :: CtFlavour -> CtFlavour -> Bool
-canDischargeF Given  _        = True
-canDischargeF Wanted Wanted   = True
-canDischargeF Wanted Derived  = True
-canDischargeF Derived Derived = True
-canDischargeF _       _       = False
+canDischarge ev1 ev2 = ctEvFlavourRole ev1 `canDischargeFR` ctEvFlavourRole ev2
+
+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
 
 
 {-
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 8c06cd9..8c0d2f9 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/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)
diff --git a/testsuite/tests/typecheck/should_compile/T10642.hs b/testsuite/tests/typecheck/should_compile/T10642.hs
new file mode 100644
index 0000000..628cfb3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T10642.hs
@@ -0,0 +1,12 @@
+{-# 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
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 48ac16e..a277b33 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/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, [''])