[commit: ghc] master: Refactor deferTcSForAllEq: Do not bind, but return EvTerm (06facab)

[git at git.haskell.org]

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

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

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

commit 06facab6e4269599a671b8aca36dd2317d58175c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Dec 2 10:12:38 2013 +0000

    Refactor deferTcSForAllEq: Do not bind, but return EvTerm


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

06facab6e4269599a671b8aca36dd2317d58175c
 compiler/typecheck/TcCanonical.lhs |    6 ++++--
 compiler/typecheck/TcSMonad.lhs    |    9 ++++-----
 2 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 392f12d..eeb7cfe 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -245,7 +245,8 @@ canClass ev cls tys
   , CtWanted { ctev_loc = loc, ctev_evar = orig_ev } <- ev
   , equalLength tvs1 tvs2
   = do { traceTcS "Creating implication for polytype coercible equality" $ ppr ev
-       ; deferTcSForAllEq Representational (loc,orig_ev) (tvs1,body1) (tvs2,body2)
+       ; ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2)
+       ; setEvBind orig_ev ev_term
        ; return Stop }
 
 canClass ev cls tys
@@ -766,7 +767,8 @@ canEqNC ev s1@(ForAllTy {}) s2@(ForAllTy {})
           canEqFailure ev s1 s2
         else
           do { traceTcS "Creating implication for polytype equality" $ ppr ev
-             ; deferTcSForAllEq Nominal (loc,orig_ev) (tvs1,body1) (tvs2,body2)
+             ; ev_term <- deferTcSForAllEq Nominal loc (tvs1,body1) (tvs2,body2)
+             ; setEvBind orig_ev ev_term
              ; return Stop } }
  | otherwise
  = do { traceTcS "Ommitting decomposition of given polytype equality" $
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 06856d7..ba46248 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1751,13 +1751,13 @@ matchFam tycon args
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 deferTcSForAllEq :: Role -- Nominal or Representational
-                 -> (CtLoc,EvVar)  -- Original wanted equality flavor
+                 -> CtLoc  -- Original wanted equality flavor
                  -> ([TyVar],TcType)   -- ForAll tvs1 body1
                  -> ([TyVar],TcType)   -- ForAll tvs2 body2
-                 -> TcS ()
+                 -> TcS EvTerm
 -- Some of this functionality is repeated from TcUnify,
 -- consider having a single place where we create fresh implications.
-deferTcSForAllEq role (loc,orig_ev) (tvs1,body1) (tvs2,body2)
+deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
  = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1
       ; let tys  = mkTyVarTys skol_tvs
             phi1 = Type.substTy subst1 body1
@@ -1790,8 +1790,7 @@ deferTcSForAllEq role (loc,orig_ev) (tvs1,body1) (tvs2,body2)
                                ; updTcSImplics (consBag imp)
                                ; return (TcLetCo ev_binds new_co) }
 
-        ; setEvBind orig_ev $
-          EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs)
+        ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs)
         }
 \end{code}