[commit: ghc] wip/rae-new-coercible: Spawn representational equalities from nominals less often. (4cdb10f)

[git at git.haskell.org]

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

On branch  : wip/rae-new-coercible
Link       : http://ghc.haskell.org/trac/ghc/changeset/4cdb10f2429338d0d0b75b6efdb2638eb428314c/ghc

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

commit 4cdb10f2429338d0d0b75b6efdb2638eb428314c
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Dec 5 14:48:20 2014 -0500

    Spawn representational equalities from nominals less often.
    
    Now, in canEqNC, not addInertCan.


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

4cdb10f2429338d0d0b75b6efdb2638eb428314c
 compiler/typecheck/TcCanonical.lhs | 33 ++++++++++++++++++++++++++++++++-
 compiler/typecheck/TcSMonad.lhs    | 33 +++------------------------------
 2 files changed, 35 insertions(+), 31 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 116cc52..b441a15 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -387,7 +387,38 @@ canHole ev occ hole_sort
 
 \begin{code}
 canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
-canEqNC ev eq_rel ty1 ty2 = can_eq_nc ev eq_rel ty1 ty1 ty2 ty2
+canEqNC ev eq_rel ty1 ty2
+  = can_eq_nc ev eq_rel ty1 ty1 ty2 ty2
+    `andWhenContinue` \ ct ->
+    do { emitReprEq ct
+       ; continueWith ct }
+
+emitReprEq :: Ct -> TcS ()
+emitReprEq (CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs
+                     , cc_eq_rel = NomEq })
+  | Just repr_ev <- sub_ev ev
+  = emitWorkNC [repr_ev]
+  where
+    repr_pred_ty = mkTcReprEqPred (mkTyVarTy tv) rhs
+    
+     -- input is a nominal CTyEqCan; output should be representational,
+     -- if possible
+    sub_ev :: CtEvidence -> Maybe CtEvidence
+    sub_ev (CtGiven { ctev_evtm = evtm, ctev_loc  = loc })
+      = Just $ CtGiven { ctev_pred = repr_pred_ty
+                       , ctev_evtm = EvCoercion $ mkTcSubCo $
+                                     evTermCoercion evtm
+                       , ctev_loc  = loc }
+        
+    sub_ev (CtDerived { ctev_loc = loc })
+      = Just $ CtDerived { ctev_pred = repr_pred_ty
+                         , ctev_loc  = loc }
+        
+        --  don't include *wanted* nominal equalities!
+    sub_ev (CtWanted {}) = Nothing
+
+-- Nothing to do for representational equalities
+emitReprEq _ = return ()
 
 can_eq_nc
    :: CtEvidence
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index e2f2e26..89860ed 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -501,42 +501,15 @@ addInertCan :: InertCans -> Ct -> InertCans
 addInertCan ics item@(CTyEqCan { cc_eq_rel = eq_rel
                                , cc_tyvar  = tv
                                , cc_rhs    = rhs })
-  = case (eq_rel, sub_ct item) of
-      (NomEq, Nothing) ->
-        ics { inert_eqs      = add_eq (inert_eqs ics)      item }
-      (NomEq, Just sub) ->
-        ics { inert_eqs      = add_eq (inert_eqs ics)      item
-            , inert_repr_eqs = add_eq (inert_repr_eqs ics) sub  }
-      (ReprEq, _) ->
-        ics { inert_repr_eqs = add_eq (inert_repr_eqs ics) item }
-
+  = case eq_rel of
+      NomEq  -> ics { inert_eqs      = add_eq (inert_eqs ics)      item }
+      ReprEq -> ics { inert_repr_eqs = add_eq (inert_repr_eqs ics) item }
   where
-    repr_pred_ty = mkTcReprEqPred (mkTyVarTy tv) rhs
-
     add_eq :: TyVarEnv EqualCtList -> Ct -> TyVarEnv EqualCtList
     add_eq old_list it
       = extendVarEnv_C (\old_eqs _new_eqs -> it : old_eqs)
                        old_list (cc_tyvar it) [it]
 
-     -- input is a nominal CTyEqCan; output should be representational,
-     -- if possible
-    sub_ct :: Ct -> Maybe Ct
-    sub_ct ct = fmap (\ev -> ct { cc_ev = ev
-                                , cc_eq_rel = ReprEq }) $
-                case cc_ev ct of
-                  CtGiven { ctev_evtm = evtm
-                          , ctev_loc  = loc } ->
-                    Just (CtGiven { ctev_pred = repr_pred_ty
-                                  , ctev_evtm = EvCoercion $ mkTcSubCo $
-                                                evTermCoercion evtm
-                                  , ctev_loc  = loc })
-                  CtDerived { ctev_loc = loc } ->
-                    Just (CtDerived { ctev_pred = repr_pred_ty
-                                    , ctev_loc  = loc })
-                      -- don't include *wanted* nominal equalities!
-                  CtWanted {} -> Nothing
-
-
 addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
   = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }