[commit: ghc] master: Define emitNewWantedEq, and use it (e1fc5a3)

[git at git.haskell.org]

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

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

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

commit e1fc5a3351bc02dc059db5c2a1079b04db18b401
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Oct 14 17:35:04 2016 +0100

    Define emitNewWantedEq, and use it
    
    This is just a minor refactoring


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

e1fc5a3351bc02dc059db5c2a1079b04db18b401
 compiler/typecheck/TcCanonical.hs |  7 +++----
 compiler/typecheck/TcInteract.hs  | 15 ++++++---------
 compiler/typecheck/TcSMonad.hs    | 11 ++++++++++-
 3 files changed, 19 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 9caef47..1a35bcc 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1456,11 +1456,10 @@ homogeniseRhsKind ev eq_rel lhs rhs build_ct
 
   | otherwise   -- Wanted and Derived. See Note [No derived kind equalities]
     -- evar :: (lhs :: k1) ~ (rhs :: k2)
-  = do { (kind_ev, kind_co) <- newWantedEq kind_loc Nominal k1 k2
+  = do { kind_co <- emitNewWantedEq kind_loc Nominal k1 k2
              -- kind_ev :: (k1 :: *) ~ (k2 :: *)
        ; traceTcS "Hetero equality gives rise to wanted kind equality" $
-           ppr (kind_ev)
-       ; emitWorkNC [kind_ev]
+           ppr (kind_co)
        ; let homo_co   = mkSymCo kind_co
            -- homo_co :: k2 ~ k1
              rhs'      = mkCastTy rhs homo_co
@@ -1471,7 +1470,7 @@ homogeniseRhsKind ev eq_rel lhs rhs build_ct
              where homo_pred = mkTcEqPredLikeEv ev lhs rhs'
            CtWanted { ctev_dest = dest } -> do
              { (type_ev, hole_co) <- newWantedEq loc role lhs rhs'
-                  -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_ev :: k1)
+                  -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_co :: k1)
              ; setWantedEq dest
                            (hole_co `mkTransCo`
                             (mkReflCo role rhs
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 05efceb..22556ed 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1416,20 +1416,17 @@ reduce_top_fun_eq old_ev fsk ax_co rhs_ty
 
   | otherwise -- We must not assign ufsk := ...ufsk...!
   = do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk)
-       ; new_ev <- case old_ev of
-           CtWanted {}  -> do { (ev, _) <- newWantedEq loc Nominal alpha_ty rhs_ty
-                              ; updWorkListTcS $
-                                  extendWorkListEq (mkNonCanonical ev)
-                              ; return ev }
+       ; new_co <- case old_ev of
+           CtWanted {}  -> emitNewWantedEq loc Nominal alpha_ty rhs_ty
            CtDerived {} -> do { ev <- newDerivedNC loc pred
                               ; updWorkListTcS (extendWorkListDerived loc ev)
-                              ; return ev }
-             where pred = mkPrimEqPred alpha_ty rhs_ty
+                              ; return (ctEvCoercion ev) }  -- Coercion is bottom
+                        where pred = mkPrimEqPred alpha_ty rhs_ty
            _ -> pprPanic "reduce_top_fun_eq" (ppr old_ev)
 
             -- By emitting this as non-canonical, we deal with all
             -- flattening, occurs-check, and ufsk := ufsk issues
-       ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev)
+       ; let final_co = ax_co `mkTcTransCo` mkTcSymCo new_co
             --    ax_co :: fam_tc args ~ rhs_ty
             --       ev :: alpha ~ rhs_ty
             --     ufsk := alpha
@@ -1440,7 +1437,7 @@ reduce_top_fun_eq old_ev fsk ax_co rhs_ty
               , nest 2 (text ":=") <+>
                    if isDerived old_ev then text "(derived)"
                    else ppr final_co
-              , text "new_ev:" <+> ppr new_ev ]
+              , text "new_co:" <+> ppr new_co ]
        ; stopWith old_ev "Fun/Top (wanted)" }
   where
     loc = ctEvLoc old_ev
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 0174b4a..27529e4 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -29,7 +29,7 @@ module TcSMonad (
     MaybeNew(..), freshGoals, isFresh, getEvTerm,
 
     newTcEvBinds,
-    newWantedEq,
+    newWantedEq, emitNewWantedEq,
     newWanted, newWantedEvVar, newWantedEvVarNC, newDerivedNC,
     newBoundEvVarId,
     unifyTyVar, unflattenFmv, reportUnifications,
@@ -2995,6 +2995,15 @@ newBoundEvVarId pred rhs
 newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
 newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
 
+emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion
+-- | Emit a new Wanted equality into the work-list
+emitNewWantedEq loc role ty1 ty2
+  | otherwise
+  = do { (ev, co) <- newWantedEq loc role ty1 ty2
+       ; updWorkListTcS $
+         extendWorkListEq (mkNonCanonical ev)
+       ; return co }
+
 -- | Make a new equality CtEvidence
 newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)
 newWantedEq loc role ty1 ty2