This BIG PATCH contains most of the work for the New Coercion Representation

[ghc-hetmet.git] / compiler / deSugar / DsBinds.lhs

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 815c0d1..85883dc 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+                dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
                 DsEvBind(..), AutoScc(..)
   ) where
 
@@ -36,6 +36,7 @@ import Digraph
 
 import TcType
 import Type
+import Coercion
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
@@ -230,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
-    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvSuperClass d _) = [d]
 
@@ -247,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
     (arg_tys, _) = splitFunTys rho
     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
                    ++ map mkWildValBinder arg_tys
-    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
                                       co_var
                         | otherwise = mkWildEvBinder p
     
@@ -263,7 +264,7 @@ dsEvTerm :: EvTerm -> CoreExpr
 dsEvTerm (EvId v)                = Var v
 dsEvTerm (EvCast v co)           = Cast (Var v) co
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvCoercion co)         = Coercion co
 dsEvTerm (EvSuperClass d n)
   = ASSERT( isClassPred (classSCTheta cls !! n) )
            -- We can only select *dictionary* superclasses
@@ -601,13 +602,9 @@ decomposeRuleLhs bndrs lhs
                                 <+> ptext (sLit "is not bound in RULE lhs"))
                       2 (ppr opt_lhs)
    pp_bndr bndr
-    | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
-    | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
-    | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
+    | isTyVar bndr  = ptext (sLit "type variable") <+> ppr bndr
+    | isEvVar bndr  = ptext (sLit "constraint") <+> ppr bndr <+> dcolon <+> ppr (evVarPred bndr)
     | otherwise     = ptext (sLit "variable") <+> ppr bndr
-
-   get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" 
-                                 (tcSplitPredTy_maybe (idType b))
 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]
@@ -634,7 +631,6 @@ otherwise we don't match when given an argument like
 NB: tcSimplifyRuleLhs is very careful not to generate complicated
     dictionary expressions that we might have to match
 
-
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack