[commit: ghc] master: Comments and debug tracing only (a351361)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/a3513618340df1f24b42ca39e95c7bf8e74f340f

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

commit a3513618340df1f24b42ca39e95c7bf8e74f340f
Author: Simon Peyton Jones <[email protected]>
Date:   Fri Oct 19 01:06:41 2012 +0100

    Comments and debug tracing only

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

 compiler/coreSyn/CoreLint.lhs      |    3 ++-
 compiler/typecheck/Inst.lhs        |   26 ++++++++++++++------------
 compiler/typecheck/TcCanonical.lhs |    2 +-
 compiler/types/Kind.lhs            |    2 +-
 4 files changed, 18 insertions(+), 15 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 250efdd..afd7e05 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -886,7 +886,8 @@ lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
            ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
                   -- Using subst_l is ok, because subst_l and subst_r
                   -- must agree on kind equalities
-           ; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2")))
+           ; unless (k `isSubKind` ktv_kind) 
+                    (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
            ; return (Type.extendTvSubst subst_l ktv t1, 
                      Type.extendTvSubst subst_r ktv t2) } 
 \end{code}
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index dac8fd1..04ea870 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -212,19 +212,21 @@ instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
 -- Instantiates the TcTheta, puts all constraints thereby generated
 -- into the LIE, and returns a HsWrapper to enclose the call site.
 
-instCallConstraints _ [] = return idHsWrapper
-
-instCallConstraints origin (pred : preds)
-  | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
-  = do  { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2)
-        ; co <- unifyType ty1 ty2
-	; co_fn <- instCallConstraints origin preds
-        ; return (co_fn <.> WpEvApp (EvCoercion co)) }
-
+instCallConstraints orig preds
+  | null preds 
+  = return idHsWrapper
   | otherwise
-  = do	{ ev_var <- emitWanted origin pred
-	; co_fn <- instCallConstraints origin preds
-	; return (co_fn <.> WpEvApp (EvId ev_var)) }
+  = do { traceTc "instCallConstraints" (pprTheta preds)
+       ; evs <- mapM go preds
+       ; return (mkWpEvApps evs) }
+  where
+    go pred 
+     | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
+     = do  { co <- unifyType ty1 ty2
+           ; return (EvCoercion co) }
+     | otherwise
+     = do { ev_var <- emitWanted orig pred
+     	  ; return (EvId ev_var) }
 
 ----------------
 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 4a8813d..3309e12 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -1110,7 +1110,7 @@ canEqLeafFunEq loc ev fn tys1 ty2  -- ev :: F tys1 ~ ty2
       ; (xi2, co2)  <- flatten     loc FMFullFlatten flav ty2
            
           -- Fancy higher-dimensional coercion between equalities!
-         -- SPJ asks why?  Why not just co : F xis1 ~ F tys1?
+          -- SPJ asks why?  Why not just co : F xis1 ~ F tys1?
        ; let fam_head = mkTyConApp fn xis1
              xco = mkHdEqPred ty2 (mkTcTyConAppCo fn cos1) co2
              -- xco :: (F xis1 ~ xi2) ~ (F tys1 ~ ty2)
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index 7318891..50d382f 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -167,7 +167,7 @@ okArrowResultKind _                = False
 --              Subkinding
 -- The tc variants are used during type-checking, where we don't want the
 -- Constraint kind to be a subkind of anything
--- After type-checking (in core), Constraint is a subkind of argTypeKind
+-- After type-checking (in core), Constraint is a subkind of openTypeKind
 isSubOpenTypeKind :: Kind -> Bool
 -- ^ True of any sub-kind of OpenTypeKind
 isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc