[commit: ghc] master: Better tc-trace messages (fa1afcd)

[git at git.haskell.org]

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

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

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

commit fa1afcde4a3f9caaa0ac37e94f1d8fa3e624405f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Dec 14 13:27:52 2017 +0000

    Better tc-trace messages


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

fa1afcde4a3f9caaa0ac37e94f1d8fa3e624405f
 compiler/typecheck/TcHsType.hs     | 10 ++++------
 compiler/typecheck/TcTyClsDecls.hs | 14 +++++++++-----
 2 files changed, 13 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index bf08b7e..a9e8afd 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -840,8 +840,10 @@ tcInferApps :: TcTyMode
             -> [LHsType GhcRn]      -- ^ Args
             -> TcM (TcType, [TcType], TcKind) -- ^ (f args, args, result kind)
 tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
-  = do { traceTc "tcInferApps" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
-       ; go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args }
+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
+       ; stuff <- go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args
+       ; traceTc "tcInferApps }" empty
+       ; return stuff }
   where
     empty_subst                      = mkEmptyTCvSubst $ mkInScopeSet $
                                        tyCoVarsOfType fun_ki
@@ -877,10 +879,6 @@ tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
                                                , ppr subst ])
            ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
                      tc_lhs_type mode arg (substTy subst $ tyBinderType ki_binder)
-           ; traceTc "tcInferApps (vis2)" (vcat [ ppr ki_binder, ppr arg
-                                                , ppr arg', ppr (typeKind arg')
-                                                , ppr (substTy subst $ tyBinderType ki_binder)
-                                                , ppr subst ])
            ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
            ; go (n+1) (arg' : acc_args) subst' (mkNakedAppTy fun arg')
                 ki_binders inner_ki args }
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 113fb9d..00f23f9 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -152,7 +152,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
   = do { let role_annots = mkRoleAnnotEnv roles
 
            -- Step 1: Typecheck the type/class declarations
-       ; traceTc "-------- tcTyClGroup ------------" empty
+       ; traceTc "---- tcTyClGroup ---- {" empty
        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
        ; tyclss <- tcTyClDecls tyclds role_annots
 
@@ -172,6 +172,8 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
        ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
            -- See Note [Check role annotations in a second pass]
 
+       ; traceTc "---- end tcTyClGroup ---- }" empty
+
            -- Step 3: Add the implicit things;
            -- we want them in the environment because
            -- they may be mentioned in interface files
@@ -379,7 +381,7 @@ kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 -- the arity
 kcTyClGroup decls
   = do  { mod <- getModule
-        ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
+        ; traceTc "---- kcTyClGroup ---- {" (text "module" <+> ppr mod $$ vcat (map ppr decls))
 
           -- Kind checking;
           --    1. Bind kind variables for decls
@@ -403,7 +405,7 @@ kcTyClGroup decls
         -- Now we have to kind generalize the flexis
         ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
 
-        ; traceTc "kcTyClGroup result" (vcat (map pp_res res))
+        ; traceTc "---- kcTyClGroup end ---- }" (vcat (map pp_res res))
         ; return res }
 
   where
@@ -807,8 +809,10 @@ tcTyClDecl roles_info (L loc decl)
 
   | otherwise
   = setSrcSpan loc $ tcAddDeclCtxt decl $
-    do { traceTc "tcTyAndCl-x" (ppr decl)
-       ; tcTyClDecl1 Nothing roles_info decl }
+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
+       ; tc <- tcTyClDecl1 Nothing roles_info decl
+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
+       ; return tc }
 
   -- "type family" declarations
 tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon