[commit: ghc] master: Tidy up kind generalisation a bit (154af13)

[Simon Peyton Jones]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/154af13a71a2711793a4d78a1b0782a9501f233c

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

commit 154af13a71a2711793a4d78a1b0782a9501f233c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Feb 16 13:48:25 2012 +0000

    Tidy up kind generalisation a bit

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

 compiler/typecheck/TcTyClsDecls.lhs |   21 ++++++++++++---------
 1 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 95d7d23..322506f 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -281,7 +281,10 @@ kcTyClGroup decls
 	     -- Step 4: generalisation
 	     -- Kind checking done for this group
              -- Now we have to kind generalize the flexis
-        ; mapM generalise (tyClsBinders decls) }}}
+        ; res <- mapM generalise (tyClsBinders decls) 
+
+        ; traceTc "kcTyClGroup result" (ppr res)
+        ; return res }}}
 
   where
     generalise :: Name -> TcM (Name, Kind)
@@ -474,7 +477,9 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
     unifyClassParmKinds (L _ tv) 
       | (n,k) <- hsTyVarNameKind tv
       , Just classParmKind <- lookup n classTyKinds 
-      = let ctxt = ptext (    sLit "When kind checking family declaration")
+      = traceTc "kcFam" (ppr k $$ ppr classParmKind $$ ppr classTyKinds)
+        >>
+        let ctxt = ptext (    sLit "When kind checking family declaration")
                           <+> ppr (tcdLName decl)
         in addErrCtxt ctxt $ unifyKind k classParmKind >> return ()
       | otherwise = return ()
@@ -630,7 +635,7 @@ tcTyClDecl1 _parent calc_isrec
           ; fds' <- mapM (addLocM tc_fundep) fundeps
           ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
           ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) }
-  ; clas <- fixM $ \ clas -> do
+          ; clas <- fixM $ \ clas -> do
 	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
 			-- need to look up its recursiveness
@@ -709,7 +714,8 @@ tcClassATs class_name parent ats at_defs
 
     at_defs_map :: NameEnv [LTyClDecl Name]
     -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
-    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) 
+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv 
+                                              (tcdName (unLoc at_def)) [at_def]) 
                         emptyNameEnv at_defs
 
     tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent
@@ -921,18 +927,15 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl 	-- Data types
               , con_details = details, con_res = res_ty }
         <- kcConDecl new_or_data con
     ; addErrCtxt (dataConCtxt name) $
-    tcTyVarBndrsKindGen tvs $ \ tvs' -> do
+      tcTyVarBndrsKindGen tvs $ \ tvs' -> do
     { ctxt' <- tcHsKindedContext ctxt
     ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
 	      (badExistential name)
-    ; traceTc "tcConDecl 1" (ppr con)
     ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
     ; let
 	tc_datacon is_infix field_lbls btys
 	  = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys
-	       ; traceTc "tcConDecl 3" (ppr name)
-
-    	       ; buildDataCon (unLoc name) is_infix
+	       ; buildDataCon (unLoc name) is_infix
     		    stricts field_lbls
     		    univ_tvs ex_tvs eq_preds ctxt' arg_tys
 		    res_ty' rep_tycon }