[commit: ghc] master: Handle Coercible (forall a. t) (forall a. t2) in TcInteract (e1e9faf)

[git at git.haskell.org]

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

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

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

commit e1e9fafcb799c6fdd1468b55b9362658d72fc382
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Dec 2 11:01:36 2013 +0000

    Handle Coercible (forall a. t) (forall a. t2) in TcInteract


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

e1e9fafcb799c6fdd1468b55b9362658d72fc382
 compiler/typecheck/TcCanonical.lhs |   18 +-----------------
 compiler/typecheck/TcInteract.lhs  |   10 ++++++++++
 2 files changed, 11 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index eeb7cfe..6f8e3db 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -19,7 +19,7 @@ import VarEnv
 import OccName( OccName )
 import Outputable
 import Control.Monad    ( when )
-import TysWiredIn ( eqTyCon, coercibleClass )
+import TysWiredIn ( eqTyCon )
 import DynFlags( DynFlags )
 import VarSet
 import TcSMonad
@@ -233,22 +233,6 @@ canClassNC ev cls tys
   = canClass ev cls tys
     `andWhenContinue` emitSuperclasses
 
--- This case implements Coercible (forall a. body) (forall b. body)
-canClass ev cls tys
-  -- See Note [Coercible instances]
-  | cls == coercibleClass
-  , [_k, ty1, ty2] <- tys
-  , tcIsForAllTy ty1
-  , tcIsForAllTy ty2
-  , let (tvs1,body1) = tcSplitForAllTys ty1
-        (tvs2,body2) = tcSplitForAllTys ty2
-  , CtWanted { ctev_loc = loc, ctev_evar = orig_ev } <- ev
-  , equalLength tvs1 tvs2
-  = do { traceTcS "Creating implication for polytype coercible equality" $ ppr ev
-       ; ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2)
-       ; setEvBind orig_ev ev_term
-       ; return Stop }
-
 canClass ev cls tys
   = do { (xis, cos) <- flattenMany FMFullFlatten ev tys
        ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 466882f..989997a 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1944,6 +1944,16 @@ getCoercibleInst loc ty1 ty2 = do
     | ty1 `tcEqType` ty2
     = do return $ GenInst []
                 $ EvCoercion (TcRefl Representational ty1)
+
+    | tcIsForAllTy ty1
+    , tcIsForAllTy ty2
+    , let (tvs1,body1) = tcSplitForAllTys ty1
+          (tvs2,body2) = tcSplitForAllTys ty2
+    , equalLength tvs1 tvs2
+    = do
+       ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2)
+       return $ GenInst [] ev_term
+
     | Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1,
       Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2,
       tc1 == tc2,