Commit 925d178e authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari
Browse files

Make traceRn behave more like traceTc

Reviewers: bgamari, austin

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2586

GHC Trac Issues: #12617
parent 9f814b2f
......@@ -215,7 +215,7 @@ newTopSrcBinder (L loc rdr_name)
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else
do { this_mod <- getModule
; traceRn (text "newTopSrcBinder" <+> (ppr this_mod $$ ppr rdr_name $$ ppr loc))
; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)
; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
}
......@@ -245,7 +245,7 @@ lookupTopBndrRn :: RdrName -> RnM Name
lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
case nopt of
Just n' -> return n'
Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n)
Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
unboundName WL_LocalTop n
lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
......@@ -497,7 +497,9 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
-- The latter does pickGREs, but we want to allow 'x'
-- even if only 'M.x' is in scope
; traceRn (text "lookupSubBndrOcc" <+> vcat [ppr the_parent, ppr rdr_name, ppr gres, ppr (pick_gres rdr_name gres)])
; traceRn "lookupSubBndrOcc"
(vcat [ ppr the_parent, ppr rdr_name
, ppr gres, ppr (pick_gres rdr_name gres)])
; case pick_gres rdr_name gres of
(gre:_) -> do { addUsedGRE warn_if_deprec gre
-- Add a usage; this is an *occurrence* site
......@@ -832,7 +834,7 @@ lookupGlobalOccRn rdr_name
= do { mb_name <- lookupGlobalOccRn_maybe rdr_name
; case mb_name of
Just n -> return n
Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name)
Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
; unboundName WL_Global rdr_name } }
lookupInfoOccRn :: RdrName -> RnM [Name]
......@@ -933,7 +935,8 @@ lookupGreRn_maybe rdr_name
[gre] -> do { addUsedGRE True gre
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; traceRn (text "name clash" <+> (ppr rdr_name $$ ppr gres $$ ppr env))
; traceRn "lookupGreRn:name clash"
(ppr rdr_name $$ ppr gres $$ ppr env)
; return (Just (head gres)) } }
lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
......@@ -950,7 +953,8 @@ lookupGreRn2_maybe rdr_name
[gre] -> do { addUsedGRE True gre
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; traceRn (text "name clash" <+> (ppr rdr_name $$ ppr gres $$ ppr env))
; traceRn "lookupGreRn_maybe:name clash"
(ppr rdr_name $$ ppr gres $$ ppr env)
; return Nothing } }
lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
......@@ -962,7 +966,7 @@ lookupGreAvailRn rdr_name
; case mb_gre of {
Just gre -> return (gre_name gre, availFromGRE gre) ;
Nothing ->
do { traceRn (text "lookupGreRn" <+> ppr rdr_name)
do { traceRn "lookupGreAvailRn" (ppr rdr_name)
; let name = mkUnboundNameRdr rdr_name
; return (name, avail name) } } }
......@@ -1004,7 +1008,7 @@ addUsedGRE warn_if_deprec gre
= do { when warn_if_deprec (warnIfDeprecated gre)
; unless (isLocalGRE gre) $
do { env <- getGblEnv
; traceRn (text "addUsedGRE" <+> ppr gre)
; traceRn "addUsedGRE" (ppr gre)
; updMutVar (tcg_used_gres env) (gre :) } }
addUsedGREs :: [GlobalRdrElt] -> RnM ()
......@@ -1014,7 +1018,7 @@ addUsedGREs :: [GlobalRdrElt] -> RnM ()
addUsedGREs gres
| null imp_gres = return ()
| otherwise = do { env <- getGblEnv
; traceRn (text "addUsedGREs" <+> ppr imp_gres)
; traceRn "addUsedGREs" (ppr imp_gres)
; updMutVar (tcg_used_gres env) (imp_gres ++) }
where
imp_gres = filterOut isLocalGRE gres
......@@ -1126,11 +1130,11 @@ lookupQualifiedNameGHCi rdr_name
_ -> -- Either we couldn't load the interface, or
-- we could but we didn't find the name in it
do { traceRn (text "lookupQualifiedNameGHCi" <+> ppr rdr_name)
do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
; return [] } }
| otherwise
= do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name)
= do { traceRn "lookupQualifedNameGHCi: off" (ppr rdr_name)
; return [] }
doc = text "Need to find" <+> ppr rdr_name
......@@ -1455,7 +1459,7 @@ lookupFixityRn_help' name occ
Just f ->
text "looking up name in iface and found:"
<+> vcat [ppr name, ppr f]
; traceRn (text "lookupFixityRn_either:" <+> msg)
; traceRn "lookupFixityRn_either:" msg
; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) }
doc = text "Checking fixity for" <+> ppr name
......@@ -1476,7 +1480,7 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name = do
traceRn $ text "get_ambiguous_fixity" <+> ppr rdr_name
traceRn "get_ambiguous_fixity" (ppr rdr_name)
rdr_env <- getGlobalRdrEnv
let elts = lookupGRE_RdrName rdr_name rdr_env
......@@ -1729,7 +1733,7 @@ checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> [a] -> RnM ()
checkShadowedOccs (global_env,local_env) get_loc_occ ns
= whenWOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr (map get_loc_occ ns))
do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
; mapM_ check_shadow ns }
where
check_shadow n
......
......@@ -888,7 +888,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
bndr_map = used_bndrs `zip` used_bndrs
-- See Note [TransStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
, trS_by = by', trS_using = using', trS_form = form
, trS_ret = return_op, trS_bind = bind_op
......
......@@ -494,7 +494,7 @@ extendGlobalRdrEnvRn avails new_fixities
; let fix_env' = foldl extend_fix_env fix_env new_gres
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
; return (gbl_env', lcl_env3) }
where
new_names = concatMap availNames avails
......@@ -560,7 +560,7 @@ getLocalNonValBinders fixity_env
; (tc_avails, tc_fldss)
<- fmap unzip $ mapM (new_tc overload_ok)
(tyClGroupTyClDecls tycl_decls)
; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
-- Bring these things into scope first
......@@ -583,7 +583,7 @@ getLocalNonValBinders fixity_env
new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
availsToNameSetWithSelectors tc_avails
flds = concat nti_fldss ++ concat tc_fldss
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
; traceRn "getLocalNonValBinders 2" (ppr avails)
; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
-- Extend tcg_field_env with new fields (this used to be the
......@@ -591,7 +591,7 @@ getLocalNonValBinders fixity_env
; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
envs = (tcg_env { tcg_field_env = field_env }, tcl_env)
; traceRn (text "getLocalNonValBinders 3" <+> vcat [ppr flds, ppr field_env])
; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
; return (envs, new_bndrs) } }
where
ValBindsIn _val_binds val_sigs = binds
......@@ -1067,7 +1067,7 @@ lookupChildren all_kids rdr_items
reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list
-> TcGblEnv -> RnM ()
reportUnusedNames _export_decls gbl_env
= do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
= do { traceRn "RUN" (ppr (tcg_dus gbl_env))
; warnUnusedImportDecls gbl_env
; warnUnusedTopBinds unused_locals
; warnMissingSignatures gbl_env }
......@@ -1137,7 +1137,8 @@ warnUnusedImportDecls gbl_env
; let usage :: [ImportDeclUsage]
usage = findImportUsage user_imports uses
; traceRn (vcat [ text "Uses:" <+> ppr uses
; traceRn "warnUnusedImportDecls" $
(vcat [ text "Uses:" <+> ppr uses
, text "Import usage" <+> ppr usage])
; whenWOptM Opt_WarnUnusedImports $
mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
......
......@@ -132,9 +132,9 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- Bind the LHSes (and their fixities) in the global rdr environment
let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
-- They are already in scope
traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
traceRn "rnSrcDecls" (ppr id_bndrs) ;
tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs)));
setEnvs tc_envs $ do {
-- Now everything is in scope, as the remaining renaming assumes.
......@@ -149,11 +149,11 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- So we content ourselves with gathering uses only; that
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn (text "Start rnTyClDecls" <+> ppr tycl_decls) ;
traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
(rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
traceRn "Start rnmono" empty ;
let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
is_boot <- tcIsHsBootOrSig ;
(rn_val_decls, bind_dus) <- if is_boot
......@@ -162,7 +162,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- bindings in an hs-boot.)
then rnTopBindsBoot tc_bndrs new_lhs
else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
traceRn "finish rnmono" (ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
......@@ -220,9 +220,9 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
in -- we return the deprecs in the env, not in the HsGroup above
tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
traceRn (text "last" <+> ppr (tcg_rdr_env final_tcg_env)) ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
traceRn (text "finish Dus" <+> ppr src_dus ) ;
traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;
traceRn "finish rnSrc" (ppr rn_group) ;
traceRn "finish Dus" (ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
......@@ -682,7 +682,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- Rename the associated types, and type signatures
-- Both need to have the instance type variables in scope
; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr ktv_names)
; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
; ((ats', adts'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
......@@ -1319,7 +1319,7 @@ rnTyClDecls tycl_ds
$$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
; traceRn (text "rnTycl dependency analysis made groups" $$ ppr all_groups)
; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
; return (all_groups, all_fvs) }
where
mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
......@@ -1636,7 +1636,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
; let doc = TySynCtx tycon
; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
\ tyvars' _ ->
do { (rhs', fvs) <- rnTySyn doc rhs
......@@ -1650,7 +1650,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
= do { tycon' <- lookupLocatedTopBndrRn tycon
; kvs <- extractDataDefnKindVars defn
; let doc = TyDataCtx tycon
; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
; ((tyvars', defn', no_kvs), fvs)
<- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
......@@ -2016,7 +2016,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
; return (Just lctx',fvs) }
; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
; let (new_details',fvs3) = (new_details,emptyFVs)
; traceRn (text "rnConDecl" <+> ppr name <+> vcat
; traceRn "rnConDecl" (ppr name <+> vcat
[ text "free_kvs:" <+> ppr kvs
, text "qtvs:" <+> ppr qtvs
, text "qtvs':" <+> ppr qtvs' ])
......@@ -2049,7 +2049,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
; mb_doc' <- rnMbLHsDoc mb_doc
; (ty', fvs) <- rnHsSigType doc ty
; traceRn (text "rnConDecl" <+> ppr names <+> vcat
; traceRn "rnConDecl" (ppr names <+> vcat
[ text "fvs:" <+> ppr fvs ])
; return (decl { con_names = new_names, con_type = ty'
, con_doc = mb_doc' },
......
......@@ -99,13 +99,13 @@ rnBracket e br_body
; recordThUse
; case isTypedBracket br_body of
True -> do { traceRn (text "Renaming typed TH bracket")
True -> do { traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <-
setStage (Brack cur_stage RnPendingTyped) $
rn_bracket cur_stage br_body
; return (HsBracket body', fvs_e) }
False -> do { traceRn (text "Renaming untyped TH bracket")
False -> do { traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
; (body', fvs_e) <-
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
......@@ -130,7 +130,9 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
| isTopLevel top_lvl
-> when (isExternalName name) (keepAlive name)
| otherwise
-> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
-> do { traceRn "rn_bracket VarBr"
(ppr name <+> ppr bind_lvl
<+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
}
......@@ -155,8 +157,8 @@ rn_bracket _ (DecBrL decls)
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env))))
; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
; return (DecBrG group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
......@@ -420,7 +422,7 @@ rnSpliceExpr splice
run_expr_splice rn_splice
| isTypedSplice rn_splice -- Run it later, in the type checker
= do { -- Ugh! See Note [Splices] above
traceRn (text "rnSpliceExpr: typed expression splice")
traceRn "rnSpliceExpr: typed expression splice" empty
; lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
......@@ -430,7 +432,7 @@ rnSpliceExpr splice
; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
| otherwise -- Run it here, see Note [Running splices in the Renamer]
= do { traceRn (text "rnSpliceExpr: untyped expression splice")
= do { traceRn "rnSpliceExpr: untyped expression splice" empty
; (rn_expr, mod_finalizers) <-
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
......@@ -542,7 +544,7 @@ rnSpliceType splice k
= (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
run_type_splice rn_splice
= do { traceRn (text "rnSpliceType: untyped type splice")
= do { traceRn "rnSpliceType: untyped type splice" empty
; (hs_ty2, mod_finalizers) <-
runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
......@@ -609,7 +611,7 @@ rnSplicePat splice
= (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
run_pat_splice rn_splice
= do { traceRn (text "rnSplicePat: untyped pattern splice")
= do { traceRn "rnSplicePat: untyped pattern splice" empty
; (pat, mod_finalizers) <-
runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-- See Note [Delaying modFinalizers in untyped splices].
......@@ -640,7 +642,7 @@ rnTopSpliceDecls splice
rnSplice splice
-- As always, be sure to checkNoErrs above lest we end up with
-- holes making it to typechecking, hence #12584.
; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
; (decls, mod_finalizers) <-
runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
; add_mod_finalizers_now mod_finalizers
......@@ -766,14 +768,16 @@ checkThLocalName name
= return () -- $(not_in_scope args)
| otherwise
= do { traceRn (text "checkThLocalName" <+> ppr name)
= do { traceRn "checkThLocalName" (ppr name)
; mb_local_use <- getStageAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_stage) ->
do { let use_lvl = thLevel use_stage
; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
<+> ppr use_stage
<+> ppr use_lvl)
; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
--------------------------------------
......@@ -817,7 +821,7 @@ check_cross_stage_lifting top_lvl name ps_var
-- If 'x' occurs many times we may get many identical
-- bindings of the same SplicePointName, but that doesn't
-- matter, although it's a mite untidy.
do { traceRn (text "checkCrossStageLifting" <+> ppr name)
do { traceRn "checkCrossStageLifting" (ppr name)
-- Construct the (lift x) expression
; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
......
......@@ -265,8 +265,8 @@ rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
, L _ (HsForAllTy {}) <- hs_ty = []
| otherwise = freeKiTyVarsTypeVars free_vars
real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$
ppr real_rdrs))
; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
ppr real_rdrs)
; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
; bindLocalNamesFV vars $
thing_inside vars }
......@@ -429,11 +429,10 @@ rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
--------------
rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnTyKiContext env (L loc cxt)
= do { traceRn (text "rncontext" <+> ppr cxt)
= do { traceRn "rncontext" (ppr cxt)
; let env' = env { rtke_what = RnConstraint }
; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
; return (L loc cxt', fvs) }
where
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
......@@ -892,10 +891,10 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
| v <- all_rn_tvs
, let name = hsLTyVarName v
, name `elemNameSet` all_dep_vars ]
; traceRn (text "bindHsTyVars" <+> (ppr env $$
ppr all_rn_kvs $$
ppr all_rn_tvs $$
ppr exp_dep_vars))
; traceRn "bindHsTyVars" (ppr env $$
ppr all_rn_kvs $$
ppr all_rn_tvs $$
ppr exp_dep_vars)
; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
warn_unused tv_bndr fvs = case mb_in_doc of
......
......@@ -238,7 +238,7 @@ tcRnModuleTcRnM hsc_env hsc_src
setGblEnv tcg_env1 $ do {
-- Rename and type check the declarations
traceRn (text "rn1a") ;
traceRn "rn1a" empty ;
tcg_env <- if isHsBootOrSig hsc_src then
tcRnHsBootDecls hsc_src local_decls
else
......@@ -247,9 +247,9 @@ tcRnModuleTcRnM hsc_env hsc_src
setGblEnv tcg_env $ do {
-- Process the export list
traceRn (text "rn4a: before exports");
traceRn "rn4a: before exports" empty;
tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
traceRn (text "rn4b: after exports") ;
traceRn "rn4b: after exports" empty ;
-- Check that main is exported (must be after rnExports)
checkMainExported tcg_env ;
......@@ -330,7 +330,7 @@ tcRnImports hsc_env import_decls
tcg_hpc = hpc_info
}) $ do {
; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
; traceRn "rn1" (ppr (imp_dep_mods imports))
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
-- of the tcg_env we have now set
......@@ -345,7 +345,7 @@ tcRnImports hsc_env import_decls
(filter (/= this_mod) (imp_orphs imports))
-- Check type-family consistency
; traceRn (text "rn1: checking family instance consistency")
; traceRn "rn1: checking family instance consistency" empty
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
$ imports }
......@@ -1177,9 +1177,9 @@ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls group
= do { -- Rename the source decls
traceRn (text "rn12") ;
traceRn "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
traceRn (text "rn13") ;
traceRn "rn13" empty ;
-- save the renamed syntax, if we want it
let { tcg_env'
......@@ -1915,7 +1915,7 @@ tcUserStmt rdr_stmt@(L loc _)
fix_env <- getFixityEnv
return (fix_env, emptyFVs)
-- Don't try to typecheck if the renamer fails!
; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump (ppr rn_stmt) ;
; ghciStep <- getGhciStepIO
......
......@@ -137,11 +137,11 @@ tcRnExports explicit_mod exports
-- turns out to be out of scope
; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
; traceRn (ppr avails)
; traceRn "Exported Avails" (ppr avails)
; let final_avails = nubAvails avails -- Combine families
final_ns = availsToNameSetWithSelectors final_avails
; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
; traceRn "rnExports: Exports:" (ppr final_avails)
; let new_tcg_env =
tcg_env { tcg_exports = final_avails,
......@@ -221,7 +221,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
(exportValid && null gre_prs)
(nullModuleExport mod)
; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres))
; traceRn "efa" (ppr mod $$ ppr all_gres)
; addUsedGREs all_gres
; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
......@@ -231,7 +231,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-- 'M.x' is in scope in several ways, we'll have
-- several members of mod_avails with the same
-- OccName.
; traceRn (vcat [ text "export mod" <+> ppr mod
; traceRn "export_mod"
(vcat [ ppr mod
, ppr new_exports ])
; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)
occs'
......@@ -463,7 +464,7 @@ lookupExportChild parent rdr_name
-- The remaining GREs are things that we *could* export here, note that
-- this includes things which have `NoParent`. Those are sorted in
-- `checkPatSynParent`.
traceRn (text "lookupExportChild original_gres:" <+> ppr original_gres)
traceRn "lookupExportChild original_gres:" (ppr original_gres)
case picked_gres original_gres of
NoOccurence ->
noMatchingParentErr original_gres
......
......@@ -41,7 +41,6 @@ module TcRnMonad(
traceTc, traceRn, traceOptTcRn, traceTcRn,
getPrintUnqualified,
printForUserTcRn,
debugDumpTcRn,
traceIf, traceHiDiffs, traceOptIf,
debugTc,
......@@ -659,18 +658,27 @@ updTcRef ref fn = liftIO $ do { old <- readIORef ref
************************************************************************
-}
-- Typechecker trace
traceTc :: String -> SDoc -> TcRn ()
traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
traceTc =
guardedTraceOptTcRn Opt_D_dump_tc_trace
-- Renamer Trace
traceRn :: String -> SDoc -> TcRn ()
traceRn =
guardedTraceOptTcRn Opt_D_dump_rn_trace
-- | Typechecker trace
traceTcN :: Int -> SDoc -> TcRn ()
traceTcN level doc
= do dflags <- getDynFlags
when (level <= traceLevel dflags && not opt_NoDebugOutput) $
traceOptTcRn Opt_D_dump_tc_trace doc
-- | Do not display a trace if `-dno-debug-output` is on or `-dtrace-level=0`.
guardedTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
guardedTraceOptTcRn flag herald doc = do
dflags <- getDynFlags
when ( traceLevel dflags >= 1
&& not opt_NoDebugOutput)
( traceOptTcRn flag (formatTraceMsg herald doc) )
traceRn :: SDoc -> TcRn ()
traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
formatTraceMsg :: String -> SDoc -> SDoc
formatTraceMsg herald doc = hang (text herald) 2 doc
-- | Output a doc if the given 'DumpFlag' is set.
--
......@@ -682,8 +690,10 @@ traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc
= do { dflags <- getDynFlags
; when (dopt flag dflags) (traceTcRn flag doc)
}
; when (dopt flag dflags)
(traceTcRn flag doc)
}
traceTcRn :: DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
......@@ -716,11 +726,6 @@ printForUserTcRn doc
; printer <- getPrintUnqualified dflags
; liftIO (printOutputForUser dflags printer doc) }
-- | Typechecker debug
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc = unless opt_NoDebugOutput $
traceOptTcRn Opt_D_dump_tc doc
{-
traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
available. Alas, they behave inconsistently with the other stuff;
......@@ -1579,7 +1584,7 @@ getTopLevelSpliceLocs
keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
keepAlive name
= do { env <- getGblEnv
; traceRn (text "keep alive" <+> ppr name)