Commit fa1afcde authored by Simon Peyton Jones's avatar Simon Peyton Jones

Better tc-trace messages

parent b1ea0475
......@@ -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 }
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment